技术宅的结界

 找回密码
 立即注册→加入我们

QQ登录

只需一步,快速开始

搜索
热搜: 下载 VB C 实现 编写
查看: 123|回复: 0
收起左侧

Sundy便笺2.2.0.2

[复制链接]

1

主题

3

帖子

58

积分

用户组: 小·技术宅

UID
5408
精华
0
威望
1 点
宅币
53 个
贡献
0 次
宅之契约
0 份
在线时间
4 小时
注册时间
2019-10-30
发表于 2019-11-9 19:18:07 | 显示全部楼层 |阅读模式

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

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

x
(部分源代码来自于他人分享)

ComCtlsBase.bas

  1. Option Explicit

  2. #Const ImplementIDEStopProtection = True

  3. #If False Then
  4. Private OLEDropModeNone, OLEDropModeManual
  5. Private CCAppearanceFlat, CCAppearance3D
  6. Private CCBorderStyleNone, CCBorderStyleSingle, CCBorderStyleThin, CCBorderStyleSunken, CCBorderStyleRaised
  7. Private CCBackStyleTransparent, CCBackStyleOpaque
  8. Private CCLeftRightAlignmentLeft, CCLeftRightAlignmentRight
  9. Private CCVerticalAlignmentTop, CCVerticalAlignmentCenter, CCVerticalAlignmentBottom
  10. Private CCIMEModeNoControl, CCIMEModeOn, CCIMEModeOff, CCIMEModeDisable, CCIMEModeHiragana, CCIMEModeKatakana, CCIMEModeKatakanaHalf, CCIMEModeAlphaFull, CCIMEModeAlpha, CCIMEModeHangulFull, CCIMEModeHangul
  11. Private CCRightToLeftModeNoControl, CCRightToLeftModeVBAME, CCRightToLeftModeSystemLocale, CCRightToLeftModeUserLocale, CCRightToLeftModeOSLanguage
  12. #End If
  13. Public Enum OLEDropModeConstants
  14.     OLEDropModeNone = vbOLEDropNone
  15.     OLEDropModeManual = vbOLEDropManual
  16. End Enum
  17. Public Enum CCAppearanceConstants
  18.     CCAppearanceFlat = 0
  19.     CCAppearance3D = 1
  20. End Enum
  21. Public Enum CCBorderStyleConstants
  22.     CCBorderStyleNone = 0
  23.     CCBorderStyleSingle = 1
  24.     CCBorderStyleThin = 2
  25.     CCBorderStyleSunken = 3
  26.     CCBorderStyleRaised = 4
  27. End Enum
  28. Public Enum CCBackStyleConstants
  29.     CCBackStyleTransparent = 0
  30.     CCBackStyleOpaque = 1
  31. End Enum
  32. Public Enum CCLeftRightAlignmentConstants
  33.     CCLeftRightAlignmentLeft = 0
  34.     CCLeftRightAlignmentRight = 1
  35. End Enum
  36. Public Enum CCVerticalAlignmentConstants
  37.     CCVerticalAlignmentTop = 0
  38.     CCVerticalAlignmentCenter = 1
  39.     CCVerticalAlignmentBottom = 2
  40. End Enum
  41. Public Enum CCIMEModeConstants
  42.     CCIMEModeNoControl = 0
  43.     CCIMEModeOn = 1
  44.     CCIMEModeOff = 2
  45.     CCIMEModeDisable = 3
  46.     CCIMEModeHiragana = 4
  47.     CCIMEModeKatakana = 5
  48.     CCIMEModeKatakanaHalf = 6
  49.     CCIMEModeAlphaFull = 7
  50.     CCIMEModeAlpha = 8
  51.     CCIMEModeHangulFull = 9
  52.     CCIMEModeHangul = 10
  53. End Enum
  54. Public Enum CCRightToLeftModeConstants
  55.     CCRightToLeftModeNoControl = 0
  56.     CCRightToLeftModeVBAME = 1
  57.     CCRightToLeftModeSystemLocale = 2
  58.     CCRightToLeftModeUserLocale = 3
  59.     CCRightToLeftModeOSLanguage = 4
  60. End Enum
  61. Private Type TINITCOMMONCONTROLSEX
  62.     dwSize As Long
  63.     dwICC As Long
  64. End Type
  65. Private Type DLLVERSIONINFO
  66.     cbSize As Long
  67.     dwMajor As Long
  68.     dwMinor As Long
  69.     dwBuildNumber As Long
  70.     dwPlatformID As Long
  71. End Type
  72. Private Type OSVERSIONINFO
  73.     dwOSVersionInfoSize As Long
  74.     dwMajorVersion As Long
  75.     dwMinorVersion As Long
  76.     dwBuildNumber As Long
  77.     dwPlatformID As Long
  78.     szCSDVersion(0 To ((128 * 2) - 1)) As Byte
  79. End Type
  80. Private Type POINTAPI
  81.     X As Long
  82.     Y As Long
  83. End Type
  84. Private Type RECT
  85.     Left As Long
  86.     Top As Long
  87.     Right As Long
  88.     Bottom As Long
  89. End Type
  90. Private Type CWPRETSTRUCT
  91.     lResult As Long
  92.     lParam As Long
  93.     wParam As Long
  94.     Message As Long
  95.     hwnd As Long
  96. End Type
  97. Private Type TRACKMOUSEEVENTSTRUCT
  98.     cbSize As Long
  99.     dwFlags As Long
  100.     hWndTrack As Long
  101.     dwHoverTime As Long
  102. End Type
  103. Private Type TMSG
  104.     hwnd As Long
  105.     Message As Long
  106.     wParam As Long
  107.     lParam As Long
  108.     Time As Long
  109.     PT As POINTAPI
  110. End Type
  111. Private Type CLSID
  112.     Data1 As Long
  113.     Data2 As Integer
  114.     Data3 As Integer
  115.     Data4(0 To 7) As Byte
  116. End Type
  117. Private Type TLOCALESIGNATURE
  118.     lsUsb(0 To 15) As Byte
  119.     lsCsbDefault(0 To 1) As Long
  120.     lsCsbSupported(0 To 1) As Long
  121. End Type
  122. Private Type TOOLINFO
  123.     cbSize As Long
  124.     uFlags As Long
  125.     hwnd As Long
  126.     uId As Long
  127.     RC As RECT
  128.     hInst As Long
  129.     lpszText As Long
  130.     lParam As Long
  131. End Type
  132. Public Declare Function ComCtlsPtrToShadowObj Lib "msvbvm60.dll" Alias "__vbaObjSetAddref" (ByRef Destination As Any, ByVal lpObject As Long) As Long
  133. Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal hMem As Long)
  134. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
  135. Private Declare Function InitCommonControlsEx Lib "comctl32" (ByRef ICCEX As TINITCOMMONCONTROLSEX) As Long
  136. 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
  137. 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
  138. 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
  139. Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
  140. Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  141. Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwThreadID As Long) As Long
  142. Private Declare Function CoTaskMemAlloc Lib "ole32" (ByVal cBytes As Long) As Long
  143. Private Declare Function ImmIsIME Lib "imm32" (ByVal hKL As Long) As Long
  144. Private Declare Function ImmCreateContext Lib "imm32" () As Long
  145. Private Declare Function ImmDestroyContext Lib "imm32" (ByVal hIMC As Long) As Long
  146. Private Declare Function ImmGetContext Lib "imm32" (ByVal hwnd As Long) As Long
  147. Private Declare Function ImmReleaseContext Lib "imm32" (ByVal hwnd As Long, ByVal hIMC As Long) As Long
  148. Private Declare Function ImmGetOpenStatus Lib "imm32" (ByVal hIMC As Long) As Long
  149. Private Declare Function ImmSetOpenStatus Lib "imm32" (ByVal hIMC As Long, ByVal fOpen As Long) As Long
  150. Private Declare Function ImmAssociateContext Lib "imm32" (ByVal hwnd As Long, ByVal hIMC As Long) As Long
  151. Private Declare Function ImmGetConversionStatus Lib "imm32" (ByVal hIMC As Long, ByRef lpfdwConversion As Long, ByRef lpfdwSentence As Long) As Long
  152. Private Declare Function ImmSetConversionStatus Lib "imm32" (ByVal hIMC As Long, ByVal lpfdwConversion As Long, ByVal lpfdwSentence As Long) As Long
  153. Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As Any, ByVal bErase As Long) As Long
  154. Private Declare Function TrackMouseEvent Lib "user32" (ByRef lpEventTrack As TRACKMOUSEEVENTSTRUCT) As Long
  155. Private Declare Function GetSystemDefaultLangID Lib "kernel32" () As Integer
  156. Private Declare Function GetUserDefaultLangID Lib "kernel32" () As Integer
  157. Private Declare Function GetUserDefaultUILanguage Lib "kernel32" () As Integer
  158. 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
  159. Private Declare Function IsDialogMessage Lib "user32" Alias "IsDialogMessageW" (ByVal hDlg As Long, ByRef lpMsg As TMSG) As Long
  160. Private Declare Function DllGetVersion Lib "comctl32" (ByRef pdvi As DLLVERSIONINFO) As Long
  161. Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExW" (ByRef lpVersionInfo As OSVERSIONINFO) As Long
  162. Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
  163. Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
  164. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  165. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  166. 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
  167. Private Declare Function SetProp Lib "user32" Alias "SetPropW" (ByVal hwnd As Long, ByVal lpString As Long, ByVal hData As Long) As Long
  168. Private Declare Function GetProp Lib "user32" Alias "GetPropW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
  169. Private Declare Function RemoveProp Lib "user32" Alias "RemovePropW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
  170. Private Declare Function SetWindowSubclass Lib "comctl32" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
  171. Private Declare Function RemoveWindowSubclass Lib "comctl32" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
  172. Private Declare Function DefSubclassProc Lib "comctl32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  173. 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
  174. Private Declare Function RemoveWindowSubclass_W2K Lib "comctl32" Alias "#412" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
  175. 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
  176. Private Const GWL_STYLE As Long = (-16)
  177. Private Const GWL_EXSTYLE As Long = (-20)
  178. Private Const WM_DESTROY As Long = &H2
  179. Private Const WM_NCDESTROY As Long = &H82
  180. Private Const WM_UAHDESTROYWINDOW As Long = &H90
  181. Private Const WM_INITDIALOG As Long = &H110
  182. Private Const WM_USER As Long = &H400
  183. Private Const E_NOTIMPL As Long = &H80004001
  184. Private Const E_NOINTERFACE As Long = &H80004002
  185. Private Const E_POINTER As Long = &H80004003
  186. Private Const S_FALSE As Long = &H1
  187. Private Const S_OK As Long = &H0
  188. Private ShellModHandle As Long, ShellModCount As Long
  189. Private CdlPDEXVTableIPDCB(0 To 5) As Long
  190. Private CdlFRHookHandle As Long
  191. Private CdlFRDialogHandle() As Long, CdlFRDialogCount As Long

  192. #If ImplementIDEStopProtection = True Then

  193. Private Declare Function VirtualAlloc Lib "kernel32" (ByRef lpAddress As Long, ByVal dwSize As Long, ByVal flAllocType As Long, ByVal flProtect As Long) As Long
  194. Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, ByRef lpflOldProtect As Long) As Long
  195. Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
  196. Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
  197. Private Const MEM_COMMIT As Long = &H1000
  198. Private Const PAGE_EXECUTE_READWRITE As Long = &H40
  199. Private Type IMAGE_DATA_DIRECTORY
  200.     VirtualAddress As Long
  201.     Size As Long
  202. End Type
  203. Private Type IMAGE_OPTIONAL_HEADER32
  204.     Magic As Integer
  205.     MajorLinkerVersion As Byte
  206.     MinorLinkerVersion As Byte
  207.     SizeOfCode As Long
  208.     SizeOfInitalizedData As Long
  209.     SizeOfUninitalizedData As Long
  210.     AddressOfEntryPoint As Long
  211.     BaseOfCode As Long
  212.     BaseOfData As Long
  213.     ImageBase As Long
  214.     SectionAlignment As Long
  215.     FileAlignment As Long
  216.     MajorOperatingSystemVer As Integer
  217.     MinorOperatingSystemVer As Integer
  218.     MajorImageVersion As Integer
  219.     MinorImageVersion As Integer
  220.     MajorSubsystemVersion As Integer
  221.     MinorSubsystemVersion As Integer
  222.     Reserved1 As Long
  223.     SizeOfImage As Long
  224.     SizeOfHeaders As Long
  225.     CheckSum As Long
  226.     Subsystem As Integer
  227.     DllCharacteristics As Integer
  228.     SizeOfStackReserve As Long
  229.     SizeOfStackCommit As Long
  230.     SizeOfHeapReserve As Long
  231.     SizeOfHeapCommit As Long
  232.     LoaderFlags As Long
  233.     NumberOfRvaAndSizes As Long
  234.     DataDirectory(15) As IMAGE_DATA_DIRECTORY
  235. End Type
  236. Private Type IMAGE_DOS_HEADER
  237.     e_magic As Integer
  238.     e_cblp As Integer
  239.     e_cp As Integer
  240.     e_crlc As Integer
  241.     e_cparhdr As Integer
  242.     e_minalloc As Integer
  243.     e_maxalloc As Integer
  244.     e_ss As Integer
  245.     e_sp As Integer
  246.     e_csum As Integer
  247.     e_ip As Integer
  248.     e_cs As Integer
  249.     e_lfarlc As Integer
  250.     e_onvo As Integer
  251.     e_res(0 To 3) As Integer
  252.     e_oemid As Integer
  253.     e_oeminfo As Integer
  254.     e_res2(0 To 9) As Integer
  255.     e_lfanew As Long
  256. End Type

  257. #End If

  258. Public Sub ComCtlsLoadShellMod()
  259.     If (ShellModHandle Or ShellModCount) = 0 Then ShellModHandle = LoadLibrary(StrPtr("Shell32.dll"))
  260.     ShellModCount = ShellModCount + 1
  261. End Sub

  262. Public Sub ComCtlsReleaseShellMod()
  263.     ShellModCount = ShellModCount - 1
  264.     If ShellModCount = 0 And ShellModHandle <> 0 Then
  265.         FreeLibrary ShellModHandle
  266.         ShellModHandle = 0
  267.     End If
  268. End Sub

  269. Public Sub ComCtlsInitCC(ByVal ICC As Long)
  270.     Dim ICCEX As TINITCOMMONCONTROLSEX
  271.     With ICCEX
  272.         .dwSize = LenB(ICCEX)
  273.         .dwICC = ICC
  274.     End With
  275.     InitCommonControlsEx ICCEX
  276. End Sub

  277. Public Sub ComCtlsShowAllUIStates(ByVal hwnd As Long)
  278.     Const WM_UPDATEUISTATE As Long = &H128
  279.     Const UIS_CLEAR As Long = 2, UISF_HIDEFOCUS As Long = &H1, UISF_HIDEACCEL As Long = &H2
  280.     SendMessage hwnd, WM_UPDATEUISTATE, MakeDWord(UIS_CLEAR, UISF_HIDEFOCUS Or UISF_HIDEACCEL), ByVal 0&
  281. End Sub

  282. Public Sub ComCtlsInitBorderStyle(ByRef dwStyle As Long, ByRef dwExStyle As Long, ByVal Value As CCBorderStyleConstants)
  283.     Const WS_BORDER As Long = &H800000, WS_DLGFRAME As Long = &H400000
  284.     Const WS_EX_CLIENTEDGE As Long = &H200, WS_EX_STATICEDGE As Long = &H20000, WS_EX_WINDOWEDGE As Long = &H100
  285.     Select Case Value
  286.     Case CCBorderStyleSingle
  287.         dwStyle = dwStyle Or WS_BORDER
  288.     Case CCBorderStyleThin
  289.         dwExStyle = dwExStyle Or WS_EX_STATICEDGE
  290.     Case CCBorderStyleSunken
  291.         dwExStyle = dwExStyle Or WS_EX_CLIENTEDGE
  292.     Case CCBorderStyleRaised
  293.         dwExStyle = dwExStyle Or WS_EX_WINDOWEDGE
  294.         dwStyle = dwStyle Or WS_DLGFRAME
  295.     End Select
  296. End Sub

  297. Public Sub ComCtlsChangeBorderStyle(ByVal hwnd As Long, ByVal Value As CCBorderStyleConstants)
  298.     Const WS_BORDER As Long = &H800000, WS_DLGFRAME As Long = &H400000
  299.     Const WS_EX_CLIENTEDGE As Long = &H200, WS_EX_STATICEDGE As Long = &H20000, WS_EX_WINDOWEDGE As Long = &H100
  300.     Dim dwStyle As Long, dwExStyle As Long
  301.     dwStyle = GetWindowLong(hwnd, GWL_STYLE)
  302.     dwExStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
  303.     If (dwStyle And WS_BORDER) = WS_BORDER Then dwStyle = dwStyle And Not WS_BORDER
  304.     If (dwStyle And WS_DLGFRAME) = WS_DLGFRAME Then dwStyle = dwStyle And Not WS_DLGFRAME
  305.     If (dwExStyle And WS_EX_STATICEDGE) = WS_EX_STATICEDGE Then dwExStyle = dwExStyle And Not WS_EX_STATICEDGE
  306.     If (dwExStyle And WS_EX_CLIENTEDGE) = WS_EX_CLIENTEDGE Then dwExStyle = dwExStyle And Not WS_EX_CLIENTEDGE
  307.     If (dwExStyle And WS_EX_WINDOWEDGE) = WS_EX_WINDOWEDGE Then dwExStyle = dwExStyle And Not WS_EX_WINDOWEDGE
  308.     Call ComCtlsInitBorderStyle(dwStyle, dwExStyle, Value)
  309.     SetWindowLong hwnd, GWL_STYLE, dwStyle
  310.     SetWindowLong hwnd, GWL_EXSTYLE, dwExStyle
  311.     Call ComCtlsFrameChanged(hwnd)
  312. End Sub

  313. Public Sub ComCtlsFrameChanged(ByVal hwnd As Long)
  314.     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
  315.     SetWindowPos hwnd, 0, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOOWNERZORDER Or SWP_NOZORDER Or SWP_FRAMECHANGED
  316. End Sub

  317. Public Sub ComCtlsInitToolTip(ByVal hwnd As Long)
  318.     Const WS_EX_TOPMOST As Long = &H8, HWND_TOPMOST As Long = (-1)
  319.     Const SWP_NOMOVE As Long = &H2, SWP_NOSIZE As Long = &H1, SWP_NOACTIVATE As Long = &H10
  320.     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
  321.     Const TTM_SETMAXTIPWIDTH As Long = (WM_USER + 24)
  322.     SendMessage hwnd, TTM_SETMAXTIPWIDTH, 0, ByVal &H7FFF&
  323. End Sub

  324. Public Sub ComCtlsCreateIMC(ByVal hwnd As Long, ByRef hIMC As Long)
  325.     If hIMC = 0 Then
  326.         hIMC = ImmCreateContext()
  327.         If hIMC <> 0 Then ImmAssociateContext hwnd, hIMC
  328.     End If
  329. End Sub

  330. Public Sub ComCtlsDestroyIMC(ByVal hwnd As Long, ByRef hIMC As Long)
  331.     If hIMC <> 0 Then
  332.         ImmAssociateContext hwnd, 0
  333.         ImmDestroyContext hIMC
  334.         hIMC = 0
  335.     End If
  336. End Sub

  337. Public Sub ComCtlsSetIMEMode(ByVal hwnd As Long, ByVal hIMCOrig As Long, ByVal Value As CCIMEModeConstants)
  338.     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
  339.     Dim hKL As Long
  340.     hKL = GetKeyboardLayout(0)
  341.     If ImmIsIME(hKL) = 0 Or hIMCOrig = 0 Then Exit Sub
  342.     Dim hIMC As Long
  343.     hIMC = ImmGetContext(hwnd)
  344.     If Value = CCIMEModeDisable Then
  345.         If hIMC <> 0 Then
  346.             ImmReleaseContext hwnd, hIMC
  347.             ImmAssociateContext hwnd, 0
  348.         End If
  349.     Else
  350.         If hIMC = 0 Then
  351.             ImmAssociateContext hwnd, hIMCOrig
  352.             hIMC = ImmGetContext(hwnd)
  353.         End If
  354.         If hIMC <> 0 And Value <> CCIMEModeNoControl Then
  355.             Dim dwConversion As Long, dwSentence As Long
  356.             ImmGetConversionStatus hIMC, dwConversion, dwSentence
  357.             Select Case Value
  358.             Case CCIMEModeOn
  359.                 ImmSetOpenStatus hIMC, 1
  360.             Case CCIMEModeOff
  361.                 ImmSetOpenStatus hIMC, 0
  362.             Case CCIMEModeHiragana
  363.                 ImmSetOpenStatus hIMC, 1
  364.                 If Not (dwConversion And IME_CMODE_NATIVE) = IME_CMODE_NATIVE Then dwConversion = dwConversion Or IME_CMODE_NATIVE
  365.                 If Not (dwConversion And IME_CMODE_FULLSHAPE) = IME_CMODE_FULLSHAPE Then dwConversion = dwConversion Or IME_CMODE_FULLSHAPE
  366.                 If (dwConversion And IME_CMODE_KATAKANA) = IME_CMODE_KATAKANA Then dwConversion = dwConversion And Not IME_CMODE_KATAKANA
  367.             Case CCIMEModeKatakana
  368.                 ImmSetOpenStatus hIMC, 1
  369.                 If Not (dwConversion And IME_CMODE_NATIVE) = IME_CMODE_NATIVE Then dwConversion = dwConversion Or IME_CMODE_NATIVE
  370.                 If Not (dwConversion And IME_CMODE_KATAKANA) = IME_CMODE_KATAKANA Then dwConversion = dwConversion Or IME_CMODE_KATAKANA
  371.                 If Not (dwConversion And IME_CMODE_FULLSHAPE) = IME_CMODE_FULLSHAPE Then dwConversion = dwConversion Or IME_CMODE_FULLSHAPE
  372.             Case CCIMEModeKatakanaHalf
  373.                 ImmSetOpenStatus hIMC, 1
  374.                 If Not (dwConversion And IME_CMODE_NATIVE) = IME_CMODE_NATIVE Then dwConversion = dwConversion Or IME_CMODE_NATIVE
  375.                 If Not (dwConversion And IME_CMODE_KATAKANA) = IME_CMODE_KATAKANA Then dwConversion = dwConversion Or IME_CMODE_KATAKANA
  376.                 If (dwConversion And IME_CMODE_FULLSHAPE) = IME_CMODE_FULLSHAPE Then dwConversion = dwConversion And Not IME_CMODE_FULLSHAPE
  377.             Case CCIMEModeAlphaFull
  378.                 ImmSetOpenStatus hIMC, 1
  379.                 If Not (dwConversion And IME_CMODE_FULLSHAPE) = IME_CMODE_FULLSHAPE Then dwConversion = dwConversion Or IME_CMODE_FULLSHAPE
  380.                 If (dwConversion And IME_CMODE_NATIVE) = IME_CMODE_NATIVE Then dwConversion = dwConversion And Not IME_CMODE_NATIVE
  381.                 If (dwConversion And IME_CMODE_KATAKANA) = IME_CMODE_KATAKANA Then dwConversion = dwConversion And Not IME_CMODE_KATAKANA
  382.             Case CCIMEModeAlpha
  383.                 ImmSetOpenStatus hIMC, 1
  384.                 If Not (dwConversion And IME_CMODE_ALPHANUMERIC) = IME_CMODE_ALPHANUMERIC Then dwConversion = dwConversion Or IME_CMODE_ALPHANUMERIC
  385.                 If (dwConversion And IME_CMODE_NATIVE) = IME_CMODE_NATIVE Then dwConversion = dwConversion And Not IME_CMODE_NATIVE
  386.                 If (dwConversion And IME_CMODE_KATAKANA) = IME_CMODE_KATAKANA Then dwConversion = dwConversion And Not IME_CMODE_KATAKANA
  387.                 If (dwConversion And IME_CMODE_FULLSHAPE) = IME_CMODE_FULLSHAPE Then dwConversion = dwConversion And Not IME_CMODE_FULLSHAPE
  388.             Case CCIMEModeHangulFull
  389.                 ImmSetOpenStatus hIMC, 1
  390.                 If Not (dwConversion And IME_CMODE_NATIVE) = IME_CMODE_NATIVE Then dwConversion = dwConversion Or IME_CMODE_NATIVE
  391.                 If Not (dwConversion And IME_CMODE_FULLSHAPE) = IME_CMODE_FULLSHAPE Then dwConversion = dwConversion Or IME_CMODE_FULLSHAPE
  392.             Case CCIMEModeHangul
  393.                 ImmSetOpenStatus hIMC, 1
  394.                 If Not (dwConversion And IME_CMODE_NATIVE) = IME_CMODE_NATIVE Then dwConversion = dwConversion Or IME_CMODE_NATIVE
  395.                 If (dwConversion And IME_CMODE_FULLSHAPE) = IME_CMODE_FULLSHAPE Then dwConversion = dwConversion And Not IME_CMODE_FULLSHAPE
  396.             End Select
  397.             ImmSetConversionStatus hIMC, dwConversion, dwSentence
  398.             ImmReleaseContext hwnd, hIMC
  399.         End If
  400.     End If
  401. End Sub

  402. Public Sub ComCtlsRequestMouseLeave(ByVal hwnd As Long)
  403.     Const TME_LEAVE As Long = &H2
  404.     Dim TME As TRACKMOUSEEVENTSTRUCT
  405.     With TME
  406.         .cbSize = LenB(TME)
  407.         .hWndTrack = hwnd
  408.         .dwFlags = TME_LEAVE
  409.     End With
  410.     TrackMouseEvent TME
  411. End Sub

  412. Public Sub ComCtlsCheckRightToLeft(ByRef Value As Boolean, ByVal UserControlValue As Boolean, ByVal ModeValue As CCRightToLeftModeConstants)
  413.     If Value = False Then Exit Sub
  414.     Select Case ModeValue
  415.     Case CCRightToLeftModeNoControl
  416.     Case CCRightToLeftModeVBAME
  417.         Value = UserControlValue
  418.     Case CCRightToLeftModeSystemLocale, CCRightToLeftModeUserLocale, CCRightToLeftModeOSLanguage
  419.         Const LOCALE_FONTSIGNATURE As Long = &H58, SORT_DEFAULT As Long = &H0
  420.         Dim LangID As Integer, LCID As Long, LocaleSig As TLOCALESIGNATURE
  421.         Select Case ModeValue
  422.         Case CCRightToLeftModeSystemLocale
  423.             LangID = GetSystemDefaultLangID()
  424.         Case CCRightToLeftModeUserLocale
  425.             LangID = GetUserDefaultLangID()
  426.         Case CCRightToLeftModeOSLanguage
  427.             LangID = GetUserDefaultUILanguage()
  428.         End Select
  429.         LCID = (SORT_DEFAULT * &H10000) Or LangID
  430.         If GetLocaleInfo(LCID, LOCALE_FONTSIGNATURE, VarPtr(LocaleSig), (LenB(LocaleSig) / 2)) <> 0 Then
  431.             ' Unicode subset bitfield 0 to 127. Bit 123 = Layout progress, horizontal from right to left
  432.             Value = CBool((LocaleSig.lsUsb(15) And (2 ^ (4 - 1))) <> 0)
  433.         End If
  434.     End Select
  435. End Sub

  436. Public Sub ComCtlsSetRightToLeft(ByVal hwnd As Long, ByVal dwMask As Long)
  437.     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
  438.     ' WS_EX_LAYOUTRTL will take care of both layout and reading order with the single flag and mirrors the window.
  439.     Dim dwExStyle As Long
  440.     dwExStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
  441.     If (dwExStyle And WS_EX_LAYOUTRTL) = WS_EX_LAYOUTRTL Then dwExStyle = dwExStyle And Not WS_EX_LAYOUTRTL
  442.     If (dwExStyle And WS_EX_RTLREADING) = WS_EX_RTLREADING Then dwExStyle = dwExStyle And Not WS_EX_RTLREADING
  443.     If (dwExStyle And WS_EX_RIGHT) = WS_EX_RIGHT Then dwExStyle = dwExStyle And Not WS_EX_RIGHT
  444.     If (dwExStyle And WS_EX_LEFTSCROLLBAR) = WS_EX_LEFTSCROLLBAR Then dwExStyle = dwExStyle And Not WS_EX_LEFTSCROLLBAR
  445.     If (dwMask And WS_EX_LAYOUTRTL) = WS_EX_LAYOUTRTL Then dwExStyle = dwExStyle Or WS_EX_LAYOUTRTL
  446.     If (dwMask And WS_EX_RTLREADING) = WS_EX_RTLREADING Then dwExStyle = dwExStyle Or WS_EX_RTLREADING
  447.     If (dwMask And WS_EX_RIGHT) = WS_EX_RIGHT Then dwExStyle = dwExStyle Or WS_EX_RIGHT
  448.     If (dwMask And WS_EX_LEFTSCROLLBAR) = WS_EX_LEFTSCROLLBAR Then dwExStyle = dwExStyle Or WS_EX_LEFTSCROLLBAR
  449.     Const WS_POPUP As Long = &H80000000
  450.     If (GetWindowLong(hwnd, GWL_STYLE) And WS_POPUP) = 0 Then
  451.         SetWindowLong hwnd, GWL_EXSTYLE, dwExStyle
  452.         InvalidateRect hwnd, ByVal 0&, 1
  453.         Call ComCtlsFrameChanged(hwnd)
  454.     Else
  455.         ' ToolTip control supports only the WS_EX_LAYOUTRTL flag.
  456.         ' Set TTF_RTLREADING flag when dwMask contains WS_EX_RTLREADING, though WS_EX_RTLREADING will not be actually set.
  457.         If (dwExStyle And WS_EX_RTLREADING) = WS_EX_RTLREADING Then dwExStyle = dwExStyle And Not WS_EX_RTLREADING
  458.         If (dwExStyle And WS_EX_RIGHT) = WS_EX_RIGHT Then dwExStyle = dwExStyle And Not WS_EX_RIGHT
  459.         If (dwExStyle And WS_EX_LEFTSCROLLBAR) = WS_EX_LEFTSCROLLBAR Then dwExStyle = dwExStyle And Not WS_EX_LEFTSCROLLBAR
  460.         SetWindowLong hwnd, GWL_EXSTYLE, dwExStyle
  461.         Const TTM_SETTOOLINFOA As Long = (WM_USER + 9)
  462.         Const TTM_SETTOOLINFOW As Long = (WM_USER + 54)
  463.         Const TTM_SETTOOLINFO As Long = TTM_SETTOOLINFOW
  464.         Const TTM_GETTOOLCOUNT As Long = (WM_USER + 13)
  465.         Const TTM_ENUMTOOLSA As Long = (WM_USER + 14)
  466.         Const TTM_ENUMTOOLSW As Long = (WM_USER + 58)
  467.         Const TTM_ENUMTOOLS As Long = TTM_ENUMTOOLSW
  468.         Const TTM_UPDATE As Long = (WM_USER + 29)
  469.         Const TTF_RTLREADING As Long = &H4
  470.         Dim i As Long, TI As TOOLINFO, Buffer As String
  471.         With TI
  472.             .cbSize = LenB(TI)
  473.             Buffer = String(80, vbNullChar)
  474.             .lpszText = StrPtr(Buffer)
  475.             For i = 1 To SendMessage(hwnd, TTM_GETTOOLCOUNT, 0, ByVal 0&)
  476.                 If SendMessage(hwnd, TTM_ENUMTOOLS, i - 1, ByVal VarPtr(TI)) <> 0 Then
  477.                     If (dwMask And WS_EX_LAYOUTRTL) = WS_EX_LAYOUTRTL Or (dwMask And WS_EX_RTLREADING) = 0 Then
  478.                         If (.uFlags And TTF_RTLREADING) = TTF_RTLREADING Then .uFlags = .uFlags And Not TTF_RTLREADING
  479.                     Else
  480.                         If (.uFlags And TTF_RTLREADING) = 0 Then .uFlags = .uFlags Or TTF_RTLREADING
  481.                     End If
  482.                     SendMessage hwnd, TTM_SETTOOLINFO, 0, ByVal VarPtr(TI)
  483.                     SendMessage hwnd, TTM_UPDATE, 0, ByVal 0&
  484.                 End If
  485.             Next i
  486.         End With
  487.     End If
  488. End Sub

  489. Public Sub ComCtlsIPPBSetDisplayStringMousePointer(ByVal MousePointer As Integer, ByRef DisplayName As String)
  490.     Select Case MousePointer
  491.     Case 0: DisplayName = "0 - Default"
  492.     Case 1: DisplayName = "1 - Arrow"
  493.     Case 2: DisplayName = "2 - Cross"
  494.     Case 3: DisplayName = "3 - I-Beam"
  495.     Case 4: DisplayName = "4 - Hand"
  496.     Case 5: DisplayName = "5 - Size"
  497.     Case 6: DisplayName = "6 - Size NE SW"
  498.     Case 7: DisplayName = "7 - Size N S"
  499.     Case 8: DisplayName = "8 - Size NW SE"
  500.     Case 9: DisplayName = "9 - Size W E"
  501.     Case 10: DisplayName = "10 - Up Arrow"
  502.     Case 11: DisplayName = "11 - Hourglass"
  503.     Case 12: DisplayName = "12 - No Drop"
  504.     Case 13: DisplayName = "13 - Arrow and Hourglass"
  505.     Case 14: DisplayName = "14 - Arrow and Question"
  506.     Case 15: DisplayName = "15 - Size All"
  507.     Case 16: DisplayName = "16 - Arrow and CD"
  508.     Case 99: DisplayName = "99 - Custom"
  509.     End Select
  510. End Sub

  511. Public Sub ComCtlsIPPBSetPredefinedStringsMousePointer(ByRef StringsOut() As String, ByRef CookiesOut() As Long)
  512.     ReDim StringsOut(0 To (17 + 1)) As String
  513.     ReDim CookiesOut(0 To (17 + 1)) As Long
  514.     StringsOut(0) = "0 - Default": CookiesOut(0) = 0
  515.     StringsOut(1) = "1 - Arrow": CookiesOut(1) = 1
  516.     StringsOut(2) = "2 - Cross": CookiesOut(2) = 2
  517.     StringsOut(3) = "3 - I-Beam": CookiesOut(3) = 3
  518.     StringsOut(4) = "4 - Hand": CookiesOut(4) = 4
  519.     StringsOut(5) = "5 - Size": CookiesOut(5) = 5
  520.     StringsOut(6) = "6 - Size NE SW": CookiesOut(6) = 6
  521.     StringsOut(7) = "7 - Size N S": CookiesOut(7) = 7
  522.     StringsOut(8) = "8 - Size NW SE": CookiesOut(8) = 8
  523.     StringsOut(9) = "9 - Size W E": CookiesOut(9) = 9
  524.     StringsOut(10) = "10 - Up Arrow": CookiesOut(10) = 10
  525.     StringsOut(11) = "11 - Hourglass": CookiesOut(11) = 11
  526.     StringsOut(12) = "12 - No Drop": CookiesOut(12) = 12
  527.     StringsOut(13) = "13 - Arrow and Hourglass": CookiesOut(13) = 13
  528.     StringsOut(14) = "14 - Arrow and Question": CookiesOut(14) = 14
  529.     StringsOut(15) = "15 - Size All": CookiesOut(15) = 15
  530.     StringsOut(16) = "16 - Arrow and CD": CookiesOut(16) = 16
  531.     StringsOut(17) = "99 - Custom": CookiesOut(17) = 99
  532. End Sub

  533. Public Sub ComCtlsIPPBSetPredefinedStringsImageList(ByRef StringsOut() As String, ByRef CookiesOut() As Long, ByRef ControlsEnum As VBRUN.ParentControls, ByRef ImageListArray() As String)
  534.     Dim ControlEnum As Object, PropUBound As Long
  535.     PropUBound = UBound(StringsOut())
  536.     ReDim Preserve StringsOut(PropUBound + 1) As String
  537.     ReDim Preserve CookiesOut(PropUBound + 1) As Long
  538.     StringsOut(PropUBound) = "(None)"
  539.     CookiesOut(PropUBound) = PropUBound
  540.     For Each ControlEnum In ControlsEnum
  541.         If TypeName(ControlEnum) = "ImageList" Then
  542.             PropUBound = UBound(StringsOut())
  543.             ReDim Preserve StringsOut(PropUBound + 1) As String
  544.             ReDim Preserve CookiesOut(PropUBound + 1) As Long
  545.             StringsOut(PropUBound) = ProperControlName(ControlEnum)
  546.             CookiesOut(PropUBound) = PropUBound
  547.         End If
  548.     Next ControlEnum
  549.     PropUBound = UBound(StringsOut())
  550.     ReDim ImageListArray(0 To PropUBound) As String
  551.     Dim i As Long
  552.     For i = 0 To PropUBound
  553.         ImageListArray(i) = StringsOut(i)
  554.     Next i
  555. End Sub

  556. Public Sub ComCtlsPPInitComboMousePointer(ByVal ComboBox As Object)
  557.     With ComboBox
  558.         .AddItem "0 - Default"
  559.         .ItemData(.NewIndex) = 0
  560.         .AddItem "1 - Arrow"
  561.         .ItemData(.NewIndex) = 1
  562.         .AddItem "2 - Cross"
  563.         .ItemData(.NewIndex) = 2
  564.         .AddItem "3 - I-Beam"
  565.         .ItemData(.NewIndex) = 3
  566.         .AddItem "4 - Hand"
  567.         .ItemData(.NewIndex) = 4
  568.         .AddItem "5 - Size"
  569.         .ItemData(.NewIndex) = 5
  570.         .AddItem "6 - Size NE SW"
  571.         .ItemData(.NewIndex) = 6
  572.         .AddItem "7 - Size N S"
  573.         .ItemData(.NewIndex) = 7
  574.         .AddItem "8 - Size NW SE"
  575.         .ItemData(.NewIndex) = 8
  576.         .AddItem "9 - Size W E"
  577.         .ItemData(.NewIndex) = 9
  578.         .AddItem "10 - Up Arrow"
  579.         .ItemData(.NewIndex) = 10
  580.         .AddItem "11 - Hourglass"
  581.         .ItemData(.NewIndex) = 11
  582.         .AddItem "12 - No Drop"
  583.         .ItemData(.NewIndex) = 12
  584.         .AddItem "13 - Arrow and Hourglass"
  585.         .ItemData(.NewIndex) = 13
  586.         .AddItem "14 - Arrow and Question"
  587.         .ItemData(.NewIndex) = 14
  588.         .AddItem "15 - Size All"
  589.         .ItemData(.NewIndex) = 15
  590.         .AddItem "16 - Arrow and CD"
  591.         .ItemData(.NewIndex) = 16
  592.         .AddItem "99 - Custom"
  593.         .ItemData(.NewIndex) = 99
  594.     End With
  595. End Sub

  596. Public Sub ComCtlsPPInitComboIMEMode(ByVal ComboBox As Object)
  597.     With ComboBox
  598.         .AddItem CCIMEModeNoControl & " - NoControl"
  599.         .ItemData(.NewIndex) = CCIMEModeNoControl
  600.         .AddItem CCIMEModeOn & " - On"
  601.         .ItemData(.NewIndex) = CCIMEModeOn
  602.         .AddItem CCIMEModeOff & " - Off"
  603.         .ItemData(.NewIndex) = CCIMEModeOff
  604.         .AddItem CCIMEModeDisable & " - Disable"
  605.         .ItemData(.NewIndex) = CCIMEModeDisable
  606.         .AddItem CCIMEModeHiragana & " - Hiragana"
  607.         .ItemData(.NewIndex) = CCIMEModeHiragana
  608.         .AddItem CCIMEModeKatakana & " - Katakana"
  609.         .ItemData(.NewIndex) = CCIMEModeKatakana
  610.         .AddItem CCIMEModeKatakanaHalf & " - KatakanaHalf"
  611.         .ItemData(.NewIndex) = CCIMEModeKatakanaHalf
  612.         .AddItem CCIMEModeAlphaFull & " - AlphaFull"
  613.         .ItemData(.NewIndex) = CCIMEModeAlphaFull
  614.         .AddItem CCIMEModeAlpha & " - Alpha"
  615.         .ItemData(.NewIndex) = CCIMEModeAlpha
  616.         .AddItem CCIMEModeHangulFull & " - HangulFull"
  617.         .ItemData(.NewIndex) = CCIMEModeHangulFull
  618.         .AddItem CCIMEModeHangul & " - Hangul"
  619.         .ItemData(.NewIndex) = CCIMEModeHangul
  620.     End With
  621. End Sub

  622. Public Sub ComCtlsPPKeyPressOnlyNumeric(ByRef KeyAscii As Integer)
  623.     If KeyAscii < 48 Or KeyAscii > 57 Then If KeyAscii <> 8 Then KeyAscii = 0
  624. End Sub

  625. Public Function ComCtlsPeekCharCode(ByVal hwnd As Long) As Long
  626.     Dim Msg As TMSG
  627.     Const PM_NOREMOVE As Long = &H0, WM_CHAR As Long = &H102
  628.     If PeekMessage(Msg, hwnd, WM_CHAR, WM_CHAR, PM_NOREMOVE) <> 0 Then ComCtlsPeekCharCode = Msg.wParam
  629. End Function

  630. Public Function ComCtlsSupportLevel() As Byte
  631.     Static Done As Boolean, Value As Byte
  632.     If Done = False Then
  633.         Dim Version As DLLVERSIONINFO
  634.         On Error Resume Next
  635.         Version.cbSize = LenB(Version)
  636.         If DllGetVersion(Version) = S_OK Then
  637.             If Version.dwMajor = 6 And Version.dwMinor = 0 Then
  638.                 Value = 1
  639.             ElseIf Version.dwMajor > 6 Or (Version.dwMajor = 6 And Version.dwMinor > 0) Then
  640.                 Value = 2
  641.             End If
  642.         End If
  643.         Done = True
  644.     End If
  645.     ComCtlsSupportLevel = Value
  646. End Function

  647. Public Function ComCtlsW2KCompatibility() As Boolean
  648.     Static Done As Boolean, Value As Boolean
  649.     If Done = False Then
  650.         Dim Version As OSVERSIONINFO
  651.         On Error Resume Next
  652.         Version.dwOSVersionInfoSize = LenB(Version)
  653.         If GetVersionEx(Version) <> 0 Then
  654.             With Version
  655.                 Const VER_PLATFORM_WIN32_NT As Long = 2
  656.                 If .dwPlatformID = VER_PLATFORM_WIN32_NT Then
  657.                     If .dwMajorVersion = 5 And .dwMinorVersion = 0 Then Value = True
  658.                 End If
  659.             End With
  660.         End If
  661.         Done = True
  662.     End If
  663.     ComCtlsW2KCompatibility = Value
  664. End Function

  665. Public Sub ComCtlsTopParentValidateControls(ByVal UserControl As Object)
  666.     With GetTopUserControl(UserControl)
  667.         If TypeOf .Parent Is VB.MDIForm Then
  668.             Dim MDIForm As VB.MDIForm
  669.             Set MDIForm = .Parent
  670.             MDIForm.ValidateControls
  671.         ElseIf TypeOf .Parent Is VB.Form Then
  672.             Dim Form As VB.Form
  673.             Set Form = .Parent
  674.             Form.ValidateControls
  675.         Else
  676.             Const IID_IPropertyPage As String = "{B196B28D-BAB4-101A-B69C-00AA00341D07}"
  677.             If VTableInterfaceSupported(.Parent, IID_IPropertyPage) = True Then
  678.                 Dim PropertyPage As VB.PropertyPage, TempPropertyPage As VB.PropertyPage
  679.                 CopyMemory TempPropertyPage, ObjPtr(.Parent), 4
  680.                 Set PropertyPage = TempPropertyPage
  681.                 CopyMemory TempPropertyPage, 0&, 4
  682.                 PropertyPage.ValidateControls
  683.             End If
  684.         End If
  685.     End With
  686. End Sub

  687. Public Sub ComCtlsSetSubclass(ByVal hwnd As Long, ByVal This As ISubclass, ByVal dwRefData As Long, Optional ByVal Name As String)
  688.     If hwnd = 0 Then Exit Sub
  689.     If Name = vbNullString Then Name = "ComCtl"
  690.     If GetProp(hwnd, StrPtr(Name & "SubclassInit")) = 0 Then
  691.         If ComCtlsW2KCompatibility() = False Then
  692.             SetWindowSubclass hwnd, AddressOf ComCtlsSubclassProc, ObjPtr(This), dwRefData
  693.         Else
  694.             SetWindowSubclass_W2K hwnd, AddressOf ComCtlsSubclassProc, ObjPtr(This), dwRefData
  695.         End If
  696.         SetProp hwnd, StrPtr(Name & "SubclassID"), ObjPtr(This)
  697.         SetProp hwnd, StrPtr(Name & "SubclassInit"), 1
  698.     End If
  699. End Sub

  700. Public Function ComCtlsDefaultProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  701.     If ComCtlsW2KCompatibility() = False Then
  702.         ComCtlsDefaultProc = DefSubclassProc(hwnd, wMsg, wParam, lParam)
  703.     Else
  704.         ComCtlsDefaultProc = DefSubclassProc_W2K(hwnd, wMsg, wParam, lParam)
  705.     End If
  706. End Function

  707. Public Sub ComCtlsRemoveSubclass(ByVal hwnd As Long, Optional ByVal Name As String)
  708.     If hwnd = 0 Then Exit Sub
  709.     If Name = vbNullString Then Name = "ComCtl"
  710.     If GetProp(hwnd, StrPtr(Name & "SubclassInit")) = 1 Then
  711.         If ComCtlsW2KCompatibility() = False Then
  712.             RemoveWindowSubclass hwnd, AddressOf ComCtlsSubclassProc, GetProp(hwnd, StrPtr(Name & "SubclassID"))
  713.         Else
  714.             RemoveWindowSubclass_W2K hwnd, AddressOf ComCtlsSubclassProc, GetProp(hwnd, StrPtr(Name & "SubclassID"))
  715.         End If
  716.         RemoveProp hwnd, StrPtr(Name & "SubclassID")
  717.         RemoveProp hwnd, StrPtr(Name & "SubclassInit")
  718.     End If
  719. End Sub

  720. 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
  721.     Select Case wMsg
  722.     Case WM_DESTROY
  723.         ComCtlsSubclassProc = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
  724.         Exit Function
  725.     Case WM_NCDESTROY, WM_UAHDESTROYWINDOW
  726.         ComCtlsSubclassProc = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
  727.         If ComCtlsW2KCompatibility() = False Then
  728.             RemoveWindowSubclass hwnd, AddressOf ComCtlsBase.ComCtlsSubclassProc, uIdSubclass
  729.         Else
  730.             RemoveWindowSubclass_W2K hwnd, AddressOf ComCtlsBase.ComCtlsSubclassProc, uIdSubclass
  731.         End If
  732.         Exit Function
  733.     End Select
  734.     On Error Resume Next
  735.     Dim This As ISubclass
  736.     Set This = PtrToObj(uIdSubclass)
  737.     If ERR.Number = 0 Then
  738.         ComCtlsSubclassProc = This.Message(hwnd, wMsg, wParam, lParam, dwRefData)
  739.     Else
  740.         ComCtlsSubclassProc = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
  741.     End If
  742. End Function

  743. Public Sub ComCtlsImlListImageIndex(ByVal Control As Object, ByVal ImageList As Variant, ByVal KeyOrIndex As Variant, ByRef ImageIndex As Long)
  744.     Dim LngValue As Long
  745.     Select Case VarType(KeyOrIndex)
  746.     Case vbLong, vbInteger, vbByte
  747.         LngValue = KeyOrIndex
  748.     Case vbString
  749.         Dim ImageListControl As Object
  750.         If IsObject(ImageList) Then
  751.             Set ImageListControl = ImageList
  752.         ElseIf VarType(ImageList) = vbString Then
  753.             Dim ControlEnum As Object, CompareName As String
  754.             For Each ControlEnum In Control.ControlsEnum
  755.                 If TypeName(ControlEnum) = "ImageList" Then
  756.                     CompareName = ProperControlName(ControlEnum)
  757.                     If CompareName = ImageList And Not CompareName = vbNullString Then
  758.                         Set ImageListControl = ControlEnum
  759.                         Exit For
  760.                     End If
  761.                 End If
  762.             Next ControlEnum
  763.         End If
  764.         If Not ImageListControl Is Nothing Then
  765.             On Error Resume Next
  766.             LngValue = ImageListControl.ListImages(KeyOrIndex).Index
  767.             On Error GoTo 0
  768.         End If
  769.         If LngValue = 0 Then ERR.Raise Number:=35601, Description:="Element not found"
  770.     Case vbDouble, vbSingle
  771.         LngValue = CLng(KeyOrIndex)
  772.     Case vbEmpty
  773.     Case Else
  774.         ERR.Raise 13
  775.     End Select
  776.     If LngValue < 0 Then ERR.Raise Number:=35600, Description:="Index out of bounds"
  777.     ImageIndex = LngValue
  778. End Sub

  779. Public Function ComCtlsLvwSortingFunctionBinary(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
  780.     ComCtlsLvwSortingFunctionBinary = This.Message(0, 0, lParam1, lParam2, 10)
  781. End Function

  782. Public Function ComCtlsLvwSortingFunctionText(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
  783.     ComCtlsLvwSortingFunctionText = This.Message(0, 0, lParam1, lParam2, 11)
  784. End Function

  785. Public Function ComCtlsLvwSortingFunctionNumeric(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
  786.     ComCtlsLvwSortingFunctionNumeric = This.Message(0, 0, lParam1, lParam2, 12)
  787. End Function

  788. Public Function ComCtlsLvwSortingFunctionCurrency(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
  789.     ComCtlsLvwSortingFunctionCurrency = This.Message(0, 0, lParam1, lParam2, 13)
  790. End Function

  791. Public Function ComCtlsLvwSortingFunctionDate(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
  792.     ComCtlsLvwSortingFunctionDate = This.Message(0, 0, lParam1, lParam2, 14)
  793. End Function

  794. Public Function ComCtlsLvwSortingFunctionGroups(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
  795.     ComCtlsLvwSortingFunctionGroups = This.Message(0, 0, lParam1, lParam2, 0)
  796. End Function

  797. Public Function ComCtlsTvwSortingFunctionBinary(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
  798.     ComCtlsTvwSortingFunctionBinary = This.Message(0, 0, lParam1, lParam2, 10)
  799. End Function

  800. Public Function ComCtlsTvwSortingFunctionText(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
  801.     ComCtlsTvwSortingFunctionText = This.Message(0, 0, lParam1, lParam2, 11)
  802. End Function

  803. Public Function ComCtlsFtcEnumFontFunction(ByVal lpELF As Long, ByVal lpTM As Long, ByVal FontType As Long, ByVal This As ISubclass) As Long
  804.     ComCtlsFtcEnumFontFunction = This.Message(0, lpELF, lpTM, FontType, 10)
  805. End Function

  806. Public Function ComCtlsCdlOFN1CallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  807.     Dim lCustData As Long
  808.     If wMsg <> WM_INITDIALOG Then
  809.         lCustData = GetProp(hDlg, StrPtr("ComCtlsCdlOFN1CallbackProcCustData"))
  810.     Else
  811.         CopyMemory lCustData, ByVal UnsignedAdd(lParam, 64), 4
  812.         SetProp hDlg, StrPtr("ComCtlsCdlOFN1CallbackProcCustData"), lCustData
  813.     End If
  814.     If lCustData <> 0 Then
  815.         Dim This As ISubclass
  816.         Set This = PtrToObj(lCustData)
  817.         ComCtlsCdlOFN1CallbackProc = This.Message(hDlg, wMsg, wParam, lParam, -1)
  818.     Else
  819.         ComCtlsCdlOFN1CallbackProc = 0
  820.     End If
  821. End Function

  822. Public Function ComCtlsCdlOFN1CallbackProcOldStyle(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  823.     Dim lCustData As Long
  824.     If wMsg <> WM_INITDIALOG Then
  825.         lCustData = GetProp(hDlg, StrPtr("ComCtlsCdlOFN1CallbackProcOldStyleCustData"))
  826.     Else
  827.         CopyMemory lCustData, ByVal UnsignedAdd(lParam, 64), 4
  828.         SetProp hDlg, StrPtr("ComCtlsCdlOFN1CallbackProcOldStyleCustData"), lCustData
  829.     End If
  830.     If lCustData <> 0 Then
  831.         Dim This As ISubclass
  832.         Set This = PtrToObj(lCustData)
  833.         ComCtlsCdlOFN1CallbackProcOldStyle = This.Message(hDlg, wMsg, wParam, lParam, -1001)
  834.     Else
  835.         ComCtlsCdlOFN1CallbackProcOldStyle = 0
  836.     End If
  837. End Function

  838. Public Function ComCtlsCdlOFN2CallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  839.     Dim lCustData As Long
  840.     If wMsg <> WM_INITDIALOG Then
  841.         lCustData = GetProp(hDlg, StrPtr("ComCtlsCdlOFN2CallbackProcCustData"))
  842.     Else
  843.         CopyMemory lCustData, ByVal UnsignedAdd(lParam, 64), 4
  844.         SetProp hDlg, StrPtr("ComCtlsCdlOFN2CallbackProcCustData"), lCustData
  845.     End If
  846.     If lCustData <> 0 Then
  847.         Dim This As ISubclass
  848.         Set This = PtrToObj(lCustData)
  849.         ComCtlsCdlOFN2CallbackProc = This.Message(hDlg, wMsg, wParam, lParam, -2)
  850.     Else
  851.         ComCtlsCdlOFN2CallbackProc = 0
  852.     End If
  853. End Function

  854. Public Function ComCtlsCdlOFN2CallbackProcOldStyle(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  855.     Dim lCustData As Long
  856.     If wMsg <> WM_INITDIALOG Then
  857.         lCustData = GetProp(hDlg, StrPtr("ComCtlsCdlOFN2CallbackProcOldStyleCustData"))
  858.     Else
  859.         CopyMemory lCustData, ByVal UnsignedAdd(lParam, 64), 4
  860.         SetProp hDlg, StrPtr("ComCtlsCdlOFN2CallbackProcOldStyleCustData"), lCustData
  861.     End If
  862.     If lCustData <> 0 Then
  863.         Dim This As ISubclass
  864.         Set This = PtrToObj(lCustData)
  865.         ComCtlsCdlOFN2CallbackProcOldStyle = This.Message(hDlg, wMsg, wParam, lParam, -1002)
  866.     Else
  867.         ComCtlsCdlOFN2CallbackProcOldStyle = 0
  868.     End If
  869. End Function

  870. Public Function ComCtlsCdlCCCallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  871.     Dim lCustData As Long
  872.     If wMsg <> WM_INITDIALOG Then
  873.         lCustData = GetProp(hDlg, StrPtr("ComCtlsCdlCCCallbackProcCustData"))
  874.     Else
  875.         CopyMemory lCustData, ByVal UnsignedAdd(lParam, 24), 4
  876.         SetProp hDlg, StrPtr("ComCtlsCdlCCCallbackProcCustData"), lCustData
  877.     End If
  878.     If lCustData <> 0 Then
  879.         Dim This As ISubclass
  880.         Set This = PtrToObj(lCustData)
  881.         ComCtlsCdlCCCallbackProc = This.Message(hDlg, wMsg, wParam, lParam, -3)
  882.     Else
  883.         ComCtlsCdlCCCallbackProc = 0
  884.     End If
  885. End Function

  886. Public Function ComCtlsCdlCFCallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  887.     Dim lCustData As Long
  888.     If wMsg <> WM_INITDIALOG Then
  889.         lCustData = GetProp(hDlg, StrPtr("ComCtlsCdlCFCallbackProcCustData"))
  890.     Else
  891.         CopyMemory lCustData, ByVal UnsignedAdd(lParam, 28), 4
  892.         SetProp hDlg, StrPtr("ComCtlsCdlCFCallbackProcCustData"), lCustData
  893.     End If
  894.     If lCustData <> 0 Then
  895.         Dim This As ISubclass
  896.         Set This = PtrToObj(lCustData)
  897.         ComCtlsCdlCFCallbackProc = This.Message(hDlg, wMsg, wParam, lParam, -4)
  898.     Else
  899.         ComCtlsCdlCFCallbackProc = 0
  900.     End If
  901. End Function

  902. Public Function ComCtlsCdlPDCallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  903.     If wMsg <> WM_INITDIALOG Then
  904.         ComCtlsCdlPDCallbackProc = 0
  905.     Else
  906.         Dim lCustData As Long
  907.         CopyMemory lCustData, ByVal UnsignedAdd(lParam, 38), 4
  908.         If lCustData <> 0 Then
  909.             Dim This As ISubclass
  910.             Set This = PtrToObj(lCustData)
  911.             ComCtlsCdlPDCallbackProc = This.Message(hDlg, wMsg, wParam, lParam, -5)
  912.         Else
  913.             ComCtlsCdlPDCallbackProc = 0
  914.         End If
  915.     End If
  916. End Function

  917. Public Function ComCtlsCdlPDEXCallbackPtr(ByVal This As ISubclass) As Long
  918.     Dim VTableData(0 To 2) As Long
  919.     VTableData(0) = GetVTableIPDCB()
  920.     VTableData(1) = 0                                                           ' RefCount is uninstantiated
  921.     VTableData(2) = ObjPtr(This)
  922.     Dim hMem As Long
  923.     hMem = CoTaskMemAlloc(12)
  924.     If hMem <> 0 Then
  925.         CopyMemory ByVal hMem, VTableData(0), 12
  926.         ComCtlsCdlPDEXCallbackPtr = hMem
  927.     End If
  928. End Function

  929. Private Function GetVTableIPDCB() As Long
  930.     If CdlPDEXVTableIPDCB(0) = 0 Then
  931.         CdlPDEXVTableIPDCB(0) = ProcPtr(AddressOf IPDCB_QueryInterface)
  932.         CdlPDEXVTableIPDCB(1) = ProcPtr(AddressOf IPDCB_AddRef)
  933.         CdlPDEXVTableIPDCB(2) = ProcPtr(AddressOf IPDCB_Release)
  934.         CdlPDEXVTableIPDCB(3) = ProcPtr(AddressOf IPDCB_InitDone)
  935.         CdlPDEXVTableIPDCB(4) = ProcPtr(AddressOf IPDCB_SelectionChange)
  936.         CdlPDEXVTableIPDCB(5) = ProcPtr(AddressOf IPDCB_HandleMessage)
  937.     End If
  938.     GetVTableIPDCB = VarPtr(CdlPDEXVTableIPDCB(0))
  939. End Function

  940. Private Function IPDCB_QueryInterface(ByVal Ptr As Long, ByRef IID As CLSID, ByRef pvObj As Long) As Long
  941.     If VarPtr(pvObj) = 0 Then
  942.         IPDCB_QueryInterface = E_POINTER
  943.         Exit Function
  944.     End If
  945.     ' IID_IPrintDialogCallback = {5852A2C3-6530-11D1-B6A3-0000F8757BF9}
  946.     If IID.Data1 = &H5852A2C3 And IID.Data2 = &H6530 And IID.Data3 = &H11D1 Then
  947.         If IID.Data4(0) = &HB6 And IID.Data4(1) = &HA3 And IID.Data4(2) = &H0 And IID.Data4(3) = &H0 _
  948.             And IID.Data4(4) = &HF8 And IID.Data4(5) = &H75 And IID.Data4(6) = &H7B And IID.Data4(7) = &HF9 Then
  949.             pvObj = Ptr
  950.             IPDCB_AddRef Ptr
  951.             IPDCB_QueryInterface = S_OK
  952.         Else
  953.             IPDCB_QueryInterface = E_NOINTERFACE
  954.         End If
  955.     Else
  956.         IPDCB_QueryInterface = E_NOINTERFACE
  957.     End If
  958. End Function

  959. Private Function IPDCB_AddRef(ByVal Ptr As Long) As Long
  960.     CopyMemory IPDCB_AddRef, ByVal UnsignedAdd(Ptr, 4), 4
  961.     IPDCB_AddRef = IPDCB_AddRef + 1
  962.     CopyMemory ByVal UnsignedAdd(Ptr, 4), IPDCB_AddRef, 4
  963. End Function

  964. Private Function IPDCB_Release(ByVal Ptr As Long) As Long
  965.     CopyMemory IPDCB_Release, ByVal UnsignedAdd(Ptr, 4), 4
  966.     IPDCB_Release = IPDCB_Release - 1
  967.     CopyMemory ByVal UnsignedAdd(Ptr, 4), IPDCB_Release, 4
  968.     If IPDCB_Release = 0 Then CoTaskMemFree Ptr
  969. End Function

  970. Private Function IPDCB_InitDone(ByVal Ptr As Long) As Long
  971.     IPDCB_InitDone = S_FALSE
  972. End Function

  973. Private Function IPDCB_SelectionChange(ByVal Ptr As Long) As Long
  974.     IPDCB_SelectionChange = S_FALSE
  975. End Function

  976. 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
  977.     If wMsg <> WM_INITDIALOG Then
  978.         IPDCB_HandleMessage = 0
  979.     Else
  980.         Dim lCustData As Long
  981.         CopyMemory lCustData, ByVal UnsignedAdd(Ptr, 8), 4
  982.         If lCustData <> 0 Then
  983.             Dim This As ISubclass
  984.             Set This = PtrToObj(lCustData)
  985.             IPDCB_HandleMessage = This.Message(hDlg, wMsg, wParam, lParam, -5)
  986.         Else
  987.             IPDCB_HandleMessage = 0
  988.         End If
  989.     End If
  990.     IPDCB_HandleMessage = S_FALSE
  991. End Function

  992. Public Function ComCtlsCdlPSDCallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  993.     If wMsg <> WM_INITDIALOG Then
  994.         ComCtlsCdlPSDCallbackProc = 0
  995.     Else
  996.         Dim lCustData As Long
  997.         CopyMemory lCustData, ByVal UnsignedAdd(lParam, 64), 4
  998.         If lCustData <> 0 Then
  999.             Dim This As ISubclass
  1000.             Set This = PtrToObj(lCustData)
  1001.             ComCtlsCdlPSDCallbackProc = This.Message(hDlg, wMsg, wParam, lParam, -7)
  1002.         Else
  1003.             ComCtlsCdlPSDCallbackProc = 0
  1004.         End If
  1005.     End If
  1006. End Function

  1007. Public Function ComCtlsCdlBIFCallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal lParam As Long, ByVal This As ISubclass) As Long
  1008.     ComCtlsCdlBIFCallbackProc = This.Message(hDlg, wMsg, 0, lParam, -8)
  1009. End Function

  1010. Public Function ComCtlsCdlFR1CallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  1011.     If wMsg <> WM_INITDIALOG Then
  1012.         ComCtlsCdlFR1CallbackProc = 0
  1013.     Else
  1014.         Dim lCustData As Long
  1015.         CopyMemory lCustData, ByVal UnsignedAdd(lParam, 28), 4
  1016.         If lCustData <> 0 Then
  1017.             Dim This As ISubclass
  1018.             Set This = PtrToObj(lCustData)
  1019.             This.Message hDlg, wMsg, wParam, lParam, -9
  1020.         End If
  1021.         ' Need to return a nonzero value or else the dialog box will not be shown.
  1022.         ComCtlsCdlFR1CallbackProc = 1
  1023.     End If
  1024. End Function

  1025. Public Function ComCtlsCdlFR2CallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  1026.     If wMsg <> WM_INITDIALOG Then
  1027.         ComCtlsCdlFR2CallbackProc = 0
  1028.     Else
  1029.         Dim lCustData As Long
  1030.         CopyMemory lCustData, ByVal UnsignedAdd(lParam, 28), 4
  1031.         If lCustData <> 0 Then
  1032.             Dim This As ISubclass
  1033.             Set This = PtrToObj(lCustData)
  1034.             This.Message hDlg, wMsg, wParam, lParam, -10
  1035.         End If
  1036.         ' Need to return a nonzero value or else the dialog box will not be shown.
  1037.         ComCtlsCdlFR2CallbackProc = 1
  1038.     End If
  1039. End Function

  1040. Public Sub ComCtlsCdlFRAddHook(ByVal hDlg As Long)
  1041.     If (CdlFRHookHandle Or CdlFRDialogCount) = 0 Then
  1042.         Const WH_GETMESSAGE As Long = 3
  1043.         CdlFRHookHandle = SetWindowsHookEx(WH_GETMESSAGE, AddressOf ComCtlsCdlFRHookProc, 0, App.ThreadID)
  1044.         ReDim CdlFRDialogHandle(0) As Long
  1045.         CdlFRDialogHandle(0) = hDlg
  1046.     Else
  1047.         ReDim Preserve CdlFRDialogHandle(0 To CdlFRDialogCount) As Long
  1048.         CdlFRDialogHandle(CdlFRDialogCount) = hDlg
  1049.     End If
  1050.     CdlFRDialogCount = CdlFRDialogCount + 1
  1051. End Sub

  1052. Public Sub ComCtlsCdlFRReleaseHook(ByVal hDlg As Long)
  1053.     CdlFRDialogCount = CdlFRDialogCount - 1
  1054.     If CdlFRDialogCount = 0 And CdlFRHookHandle <> 0 Then
  1055.         UnhookWindowsHookEx CdlFRHookHandle
  1056.         CdlFRHookHandle = 0
  1057.         Erase CdlFRDialogHandle()
  1058.     Else
  1059.         If CdlFRDialogCount > 0 Then
  1060.             Dim i As Long
  1061.             For i = 0 To CdlFRDialogCount
  1062.                 If CdlFRDialogHandle(i) = hDlg And i < CdlFRDialogCount Then
  1063.                     CdlFRDialogHandle(i) = CdlFRDialogHandle(i + 1)
  1064.                 End If
  1065.             Next i
  1066.             ReDim Preserve CdlFRDialogHandle(0 To CdlFRDialogCount - 1) As Long
  1067.         End If
  1068.     End If
  1069. End Sub

  1070. Private Function ComCtlsCdlFRHookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  1071.     Const HC_ACTION As Long = 0, PM_REMOVE As Long = &H1
  1072.     Const WM_KEYFIRST As Long = &H100, WM_KEYLAST As Long = &H108, WM_NULL As Long = &H0
  1073.     If nCode >= HC_ACTION And wParam = PM_REMOVE Then
  1074.         Dim Msg As TMSG
  1075.         CopyMemory Msg, ByVal lParam, LenB(Msg)
  1076.         If Msg.Message >= WM_KEYFIRST And Msg.Message <= WM_KEYLAST Then
  1077.             If CdlFRDialogCount > 0 Then
  1078.                 Dim i As Long
  1079.                 For i = 0 To CdlFRDialogCount - 1
  1080.                     If IsDialogMessage(CdlFRDialogHandle(i), Msg) <> 0 Then
  1081.                         Msg.Message = WM_NULL
  1082.                         Msg.wParam = 0
  1083.                         Msg.lParam = 0
  1084.                         CopyMemory ByVal lParam, Msg, LenB(Msg)
  1085.                         Exit For
  1086.                     End If
  1087.                 Next i
  1088.             End If
  1089.         End If
  1090.     End If
  1091.     ComCtlsCdlFRHookProc = CallNextHookEx(CdlFRHookHandle, nCode, wParam, lParam)
  1092. End Function

  1093. Public Sub ComCtlsInitIDEStopProtection()
  1094.    
  1095.     #If ImplementIDEStopProtection = True Then
  1096.         
  1097.         If InIDE() = True Then
  1098.             Dim ASMWrapper As Long, RestorePointer As Long, OldAddress As Long
  1099.             ASMWrapper = VirtualAlloc(ByVal 0, 20, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
  1100.             OldAddress = GetProcAddress(GetModuleHandle(StrPtr("vba6.dll")), "EbProjectReset")
  1101.             RestorePointer = HookIATEntry("vb6.exe", "vba6.dll", "EbProjectReset", ASMWrapper)
  1102.             WriteCall ASMWrapper, AddressOf ComCtlsIDEStopProtectionHandler
  1103.             WriteByte ASMWrapper, &HC7                                          ' MOV
  1104.             WriteByte ASMWrapper, &H5
  1105.             WriteLong ASMWrapper, RestorePointer                                ' IAT Entry
  1106.             WriteLong ASMWrapper, OldAddress                                    ' Address from EbProjectReset
  1107.             WriteJump ASMWrapper, OldAddress
  1108.         End If
  1109.         
  1110.     #End If
  1111.    
  1112. End Sub

  1113. #If ImplementIDEStopProtection = True Then

  1114. Private Sub ComCtlsIDEStopProtectionHandler()
  1115.     On Error Resume Next
  1116.     Call RemoveAllVTableSubclass(VTableInterfaceInPlaceActiveObject)
  1117.     Call RemoveAllVTableSubclass(VTableInterfaceControl)
  1118.     Call RemoveAllVTableSubclass(VTableInterfacePerPropertyBrowsing)
  1119.     Dim AppForm As Form, CurrControl As Control
  1120.     For Each AppForm In Forms
  1121.         For Each CurrControl In AppForm.Controls
  1122.             Select Case TypeName(CurrControl)
  1123.             Case "Animation", "DTPicker", "MonthView", "Slider", "StatusBar", "TabStrip", "ListBoxW", "ListView", "TreeView", "IPAddress", "ToolBar", "UpDown", "SpinBox", "Pager", "OptionButtonW", "CheckBoxW", "CommandButtonW", "TextBoxW", "HotKey", "CoolBar", "LinkLabel", "CommandLink"
  1124.                 Call ComCtlsRemoveSubclass(CurrControl.hwnd)
  1125.                 Call ComCtlsRemoveSubclass(CurrControl.hWndUserControl)
  1126.             Case "ProgressBar", "FrameW"
  1127.                 Call ComCtlsRemoveSubclass(CurrControl.hwnd)
  1128.             Case "ComboBoxW", "FontCombo"
  1129.                 Call ComCtlsRemoveSubclass(CurrControl.hwnd)
  1130.                 If CurrControl.hWndEdit <> 0 Then Call ComCtlsRemoveSubclass(CurrControl.hWndEdit)
  1131.                 If CurrControl.hWndList <> 0 Then Call ComCtlsRemoveSubclass(CurrControl.hWndList)
  1132.                 Call ComCtlsRemoveSubclass(CurrControl.hWndUserControl)
  1133.             Case "ImageCombo"
  1134.                 Call ComCtlsRemoveSubclass(CurrControl.hwnd)
  1135.                 If CurrControl.hWndCombo <> 0 Then Call ComCtlsRemoveSubclass(CurrControl.hWndCombo)
  1136.                 If CurrControl.hWndEdit <> 0 Then Call ComCtlsRemoveSubclass(CurrControl.hWndEdit)
  1137.                 If CurrControl.hWndList <> 0 Then Call ComCtlsRemoveSubclass(CurrControl.hWndList)
  1138.                 Call ComCtlsRemoveSubclass(CurrControl.hWndUserControl)
  1139.             Case "RichTextBox", "MCIWnd", "SysInfo"
  1140.                 CurrControl.IDEStop                                             ' Hidden
  1141.             End Select
  1142.         Next CurrControl
  1143.     Next AppForm
  1144.     If CdlFRDialogCount > 0 Then
  1145.         Dim DialogHandle() As Long
  1146.         DialogHandle() = CdlFRDialogHandle()
  1147.         Const WM_CLOSE As Long = &H10
  1148.         Dim i As Long
  1149.         For i = 0 To CdlFRDialogCount - 1
  1150.             SendMessage DialogHandle(i), WM_CLOSE, 0, ByVal 0&
  1151.             DoEvents
  1152.         Next i
  1153.     End If
  1154. End Sub

  1155. Private Function HookIATEntry(ByVal Module As String, ByVal Lib As String, ByVal Fnc As String, ByVal NewAddr As Long) As Long
  1156.     Dim hMod As Long, OldLibFncAddr As Long
  1157.     Dim lpIAT As Long, IATLen As Long, IATPos As Long
  1158.     Dim DOSHdr As IMAGE_DOS_HEADER
  1159.     Dim PEHdr As IMAGE_OPTIONAL_HEADER32
  1160.     hMod = GetModuleHandle(StrPtr(Module))
  1161.     If hMod = 0 Then Exit Function
  1162.     OldLibFncAddr = GetProcAddress(GetModuleHandle(StrPtr(Lib)), Fnc)
  1163.     If OldLibFncAddr = 0 Then Exit Function
  1164.     CopyMemory DOSHdr, ByVal hMod, LenB(DOSHdr)
  1165.     CopyMemory PEHdr, ByVal UnsignedAdd(hMod, DOSHdr.e_lfanew), LenB(PEHdr)
  1166.     Const IMAGE_NT_SIGNATURE As Long = &H4550
  1167.     If PEHdr.Magic = IMAGE_NT_SIGNATURE Then
  1168.         lpIAT = UnsignedAdd(PEHdr.DataDirectory(15).VirtualAddress, hMod)
  1169.         IATLen = PEHdr.DataDirectory(15).Size
  1170.         IATPos = lpIAT
  1171.         Do Until CLngToULng(IATPos) >= CLngToULng(UnsignedAdd(lpIAT, IATLen))
  1172.             If DeRef(IATPos) = OldLibFncAddr Then
  1173.                 VirtualProtect IATPos, 4, PAGE_EXECUTE_READWRITE, 0
  1174.                 CopyMemory ByVal IATPos, NewAddr, 4
  1175.                 HookIATEntry = IATPos
  1176.                 Exit Do
  1177.             End If
  1178.             IATPos = UnsignedAdd(IATPos, 4)
  1179.         Loop
  1180.     End If
  1181. End Function

  1182. Private Function DeRef(ByVal Addr As Long) As Long
  1183.     CopyMemory DeRef, ByVal Addr, 4
  1184. End Function

  1185. Private Sub WriteJump(ByRef ASM As Long, ByRef Addr As Long)
  1186.     WriteByte ASM, &HE9
  1187.     WriteLong ASM, Addr - ASM - 4
  1188. End Sub

  1189. Private Sub WriteCall(ByRef ASM As Long, ByRef Addr As Long)
  1190.     WriteByte ASM, &HE8
  1191.     WriteLong ASM, Addr - ASM - 4
  1192. End Sub

  1193. Private Sub WriteLong(ByRef ASM As Long, ByRef Lng As Long)
  1194.     CopyMemory ByVal ASM, Lng, 4
  1195.     ASM = ASM + 4
  1196. End Sub

  1197. Private Sub WriteByte(ByRef ASM As Long, ByRef b As Byte)
  1198.     CopyMemory ByVal ASM, b, 1
  1199.     ASM = ASM + 1
  1200. End Sub

  1201. #End If
复制代码
Common.bas
  1. Option Explicit
  2. Private Type MSGBOXPARAMS
  3.     cbSize As Long
  4.     hWndOwner As Long
  5.     hInstance As Long
  6.     lpszText As Long
  7.     lpszCaption As Long
  8.     dwStyle As Long
  9.     lpszIcon As Long
  10.     dwContextHelpID As Long
  11.     lpfnMsgBoxCallback As Long
  12.     dwLanguageId As Long
  13. End Type
  14. Private Type RECT
  15.     Left As Long
  16.     Top As Long
  17.     Right As Long
  18.     Bottom As Long
  19. End Type
  20. Private Type BITMAP
  21.     BMType As Long
  22.     BMWidth As Long
  23.     BMHeight As Long
  24.     BMWidthBytes As Long
  25.     BMPlanes As Integer
  26.     BMBitsPixel As Integer
  27.     BMBits As Long
  28. End Type
  29. Private Type SAFEARRAYBOUND
  30.     cElements As Long
  31.     lLbound As Long
  32. End Type
  33. Private Type SAFEARRAY1D
  34.     cDims As Integer
  35.     fFeatures As Integer
  36.     cbElements As Long
  37.     cLocks As Long
  38.     pvData As Long
  39.     Bounds As SAFEARRAYBOUND
  40. End Type
  41. Private Type PICTDESC
  42.     cbSizeOfStruct As Long
  43.     PicType As Long
  44.     hImage As Long
  45.     XExt As Long
  46.     YExt As Long
  47. End Type
  48. Private Type CLSID
  49.     Data1 As Long
  50.     Data2 As Integer
  51.     Data3 As Integer
  52.     Data4(0 To 7) As Byte
  53. End Type
  54. Private Type FILETIME
  55.     dwLowDateTime As Long
  56.     dwHighDateTime As Long
  57. End Type
  58. Private Type SYSTEMTIME
  59.     wYear As Integer
  60.     wMonth As Integer
  61.     wDayOfWeek As Integer
  62.     wDay As Integer
  63.     wHour As Integer
  64.     wMinute As Integer
  65.     wSecond As Integer
  66.     wMilliseconds As Integer
  67. End Type
  68. Private Const MAX_PATH As Long = 260
  69. Private Type WIN32_FIND_DATA
  70.     dwFileAttributes As Long
  71.     FTCreationTime As FILETIME
  72.     FTLastAccessTime As FILETIME
  73.     FTLastWriteTime As FILETIME
  74.     nFileSizeHigh As Long
  75.     nFileSizeLow As Long
  76.     dwReserved0 As Long
  77.     dwReserved1 As Long
  78.     lpszFileName(0 To ((MAX_PATH * 2) - 1)) As Byte
  79.     lpszAlternateFileName(0 To ((14 * 2) - 1)) As Byte
  80. End Type
  81. Private Type VS_FIXEDFILEINFO
  82.     dwSignature As Long
  83.     dwStrucVersionLo As Integer
  84.     dwStrucVersionHi As Integer
  85.     dwFileVersionMSLo As Integer
  86.     dwFileVersionMSHi As Integer
  87.     dwFileVersionLSLo As Integer
  88.     dwFileVersionLSHi As Integer
  89.     dwProductVersionMSLo As Integer
  90.     dwProductVersionMSHi As Integer
  91.     dwProductVersionLSLo As Integer
  92.     dwProductVersionLSHi As Integer
  93.     dwFileFlagsMask As Long
  94.     dwFileFlags As Long
  95.     dwFileOS As Long
  96.     dwFileType As Long
  97.     dwFileSubtype As Long
  98.     dwFileDateMS As Long
  99.     dwFileDateLS As Long
  100. End Type
  101. Private Const LF_FACESIZE As Long = 32
  102. Private Const FW_NORMAL As Long = 400
  103. Private Const FW_BOLD As Long = 700
  104. Private Const DEFAULT_QUALITY As Long = 0
  105. Private Type LOGFONT
  106.     LFHeight As Long
  107.     LFWidth As Long
  108.     LFEscapement As Long
  109.     LFOrientation As Long
  110.     LFWeight As Long
  111.     LFItalic As Byte
  112.     LFUnderline As Byte
  113.     LFStrikeOut As Byte
  114.     LFCharset As Byte
  115.     LFOutPrecision As Byte
  116.     LFClipPrecision As Byte
  117.     LFQuality As Byte
  118.     LFPitchAndFamily As Byte
  119.     LFFaceName(0 To ((LF_FACESIZE * 2) - 1)) As Byte
  120. End Type
  121. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
  122. Private Declare Function ArrPtr Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Var() As Any) As Long
  123. Private Declare Function MessageBoxIndirect Lib "user32" Alias "MessageBoxIndirectW" (ByRef lpMsgBoxParams As MSGBOXPARAMS) As Long
  124. Private Declare Function GetActiveWindow Lib "user32" () As Long
  125. Private Declare Function GetForegroundWindow Lib "user32" () As Long
  126. Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesW" (ByVal lpFileName As Long) As Long
  127. Private Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesW" (ByVal lpFileName As Long, ByVal dwFileAttributes As Long) As Long
  128. 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
  129. Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, ByRef lpFileSizeHigh As Long) As Long
  130. Private Declare Function GetFileTime Lib "kernel32" (ByVal hFile As Long, ByVal lpCreationTime As Long, ByVal lpLastAccessTime As Long, ByVal lpLastWriteTime As Long) As Long
  131. Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (ByVal lpFileTime As Long, ByVal lpLocalFileTime As Long) As Long
  132. Private Declare Function FileTimeToSystemTime Lib "kernel32" (ByVal lpFileTime As Long, ByVal lpSystemTime As Long) As Long
  133. Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileW" (ByVal lpFileName As Long, ByRef lpFindFileData As WIN32_FIND_DATA) As Long
  134. Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileW" (ByVal hFindFile As Long, ByRef lpFindFileData As WIN32_FIND_DATA) As Long
  135. Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
  136. Private Declare Function GetVolumePathName Lib "kernel32" Alias "GetVolumePathNameW" (ByVal lpFileName As Long, ByVal lpVolumePathName As Long, ByVal cch As Long) As Long
  137. 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
  138. Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryW" (ByVal lpPathName As Long, ByVal lpSecurityAttributes As Long) As Long
  139. Private Declare Function RemoveDirectory Lib "kernel32" Alias "RemoveDirectoryW" (ByVal lpPathName As Long) As Long
  140. Private Declare Function GetCurrentDirectory Lib "kernel32" Alias "GetCurrentDirectoryW" (ByVal nBufferLength As Long, ByVal lpBuffer As Long) As Long
  141. 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
  142. Private Declare Function GetFileVersionInfoSize Lib "Version" Alias "GetFileVersionInfoSizeW" (ByVal lpFileName As Long, ByVal lpdwHandle As Long) As Long
  143. 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
  144. Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
  145. Private Declare Function GetCommandLine Lib "kernel32" Alias "GetCommandLineW" () As Long
  146. Private Declare Function PathGetArgs Lib "shlwapi" Alias "PathGetArgsW" (ByVal lpszPath As Long) As Long
  147. Private Declare Function SysReAllocString Lib "oleaut32" (ByVal pbString As Long, ByVal pszStrPtr As Long) As Long
  148. Private Declare Function VarDecFromI8 Lib "oleaut32" (ByVal LoDWord As Long, ByVal HiDWord As Long, ByRef pDecOut As Variant) As Long
  149. Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameW" (ByVal hModule As Long, ByVal lpFileName As Long, ByVal nSize As Long) As Long
  150. Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
  151. Private Declare Function EmptyClipboard Lib "user32" () As Long
  152. Private Declare Function CloseClipboard Lib "user32" () As Long
  153. Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
  154. Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
  155. Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
  156. Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
  157. Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
  158. Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextW" (ByVal hwnd As Long, ByVal lpString As Long, ByVal cch As Long) As Long
  159. Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthW" (ByVal hwnd As Long) As Long
  160. Private Declare Function GetClassName Lib "user32" Alias "GetClassNameW" (ByVal hwnd As Long, ByVal lpClassName As Long, ByVal nMaxCount As Long) As Long
  161. Private Declare Function GetSystemWindowsDirectory Lib "kernel32" Alias "GetSystemWindowsDirectoryW" (ByVal lpBuffer As Long, ByVal nSize As Long) As Long
  162. Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryW" (ByVal lpBuffer As Long, ByVal nSize As Long) As Long
  163. Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  164. Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
  165. 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
  166. Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
  167. Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectW" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
  168. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  169. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  170. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  171. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
  172. Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
  173. Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
  174. 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
  175. 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
  176. Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
  177. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  178. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
  179. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  180. Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
  181. Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectW" (ByRef lpLogFont As LOGFONT) As Long
  182. Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
  183. Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  184. Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
  185. Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
  186. Private Declare Function OleTranslateColor Lib "oleaut32" (ByVal Color As Long, ByVal hPal As Long, ByRef RGBResult As Long) As Long
  187. 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
  188. 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
  189. Private Declare Function OleCreatePictureIndirect Lib "olepro32" (ByRef pPictDesc As PICTDESC, ByRef riid As Any, ByVal fPictureOwnsHandle As Long, ByRef pIPicture As IPicture) As Long
  190. Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ByRef pStream As IUnknown) As Long
  191. 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
  192. 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

  193. ' (VB-Overwrite)
  194. Public Function MsgBox(ByVal Prompt As String, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, Optional ByVal Title As String) As VbMsgBoxResult
  195.     Dim MSGBOXP As MSGBOXPARAMS
  196.     With MSGBOXP
  197.         .cbSize = LenB(MSGBOXP)
  198.         If (Buttons And vbSystemModal) = 0 Then
  199.             If Not Screen.ActiveForm Is Nothing Then
  200.                 .hWndOwner = Screen.ActiveForm.hwnd
  201.             Else
  202.                 .hWndOwner = GetActiveWindow()
  203.             End If
  204.         Else
  205.             .hWndOwner = GetForegroundWindow()
  206.         End If
  207.         .hInstance = App.hInstance
  208.         .lpszText = StrPtr(Prompt)
  209.         If Title = vbNullString Then Title = App.Title
  210.         .lpszCaption = StrPtr(Title)
  211.         .dwStyle = Buttons
  212.     End With
  213.     MsgBox = MessageBoxIndirect(MSGBOXP)
  214. End Function

  215. ' (VB-Overwrite)
  216. Public Sub SendKeys(ByRef Text As String, Optional ByRef Wait As Boolean)
  217.     CreateObject("WScript.Shell").SendKeys Text, Wait
  218. End Sub

  219. ' (VB-Overwrite)
  220. Public Function GetAttr(ByVal PathName As String) As VbFileAttribute
  221.     Const INVALID_FILE_ATTRIBUTES As Long = (-1)
  222.     Const FILE_ATTRIBUTE_NORMAL As Long = &H80
  223.     If Left$(PathName, 2) = "\\" Then PathName = "UNC\" & Mid$(PathName, 3)
  224.     Dim dwAttributes As Long
  225.     dwAttributes = GetFileAttributes(StrPtr("\\?\" & PathName))
  226.     If dwAttributes = INVALID_FILE_ATTRIBUTES Then
  227.         ERR.Raise 53
  228.     ElseIf dwAttributes = FILE_ATTRIBUTE_NORMAL Then
  229.         GetAttr = vbNormal
  230.     Else
  231.         GetAttr = dwAttributes
  232.     End If
  233. End Function

  234. ' (VB-Overwrite)
  235. Public Sub SetAttr(ByVal PathName As String, ByVal Attributes As VbFileAttribute)
  236.     Const FILE_ATTRIBUTE_NORMAL As Long = &H80
  237.     Dim dwAttributes As Long
  238.     If Attributes = vbNormal Then
  239.         dwAttributes = FILE_ATTRIBUTE_NORMAL
  240.     Else
  241.         If (Attributes And (vbVolume Or vbDirectory Or vbAlias)) <> 0 Then ERR.Raise 5
  242.         dwAttributes = Attributes
  243.     End If
  244.     If Left$(PathName, 2) = "\\" Then PathName = "UNC\" & Mid$(PathName, 3)
  245.     If SetFileAttributes(StrPtr("\\?\" & PathName), dwAttributes) = 0 Then ERR.Raise 53
  246. End Sub

  247. ' (VB-Overwrite)
  248. Public Sub MkDir(ByVal PathName As String)
  249.     If Left$(PathName, 2) = "\\" Then PathName = "UNC\" & Mid$(PathName, 3)
  250.     If CreateDirectory(StrPtr("\\?\" & PathName), 0) = 0 Then
  251.         Const ERROR_PATH_NOT_FOUND As Long = 3
  252.         If ERR.LastDllError = ERROR_PATH_NOT_FOUND Then
  253.             ERR.Raise 76
  254.         Else
  255.             ERR.Raise 75
  256.         End If
  257.     End If
  258. End Sub

  259. ' (VB-Overwrite)
  260. Public Sub RmDir(ByVal PathName As String)
  261.     If Left$(PathName, 2) = "\\" Then PathName = "UNC\" & Mid$(PathName, 3)
  262.     If RemoveDirectory(StrPtr("\\?\" & PathName)) = 0 Then
  263.         Const ERROR_FILE_NOT_FOUND As Long = 2
  264.         If ERR.LastDllError = ERROR_FILE_NOT_FOUND Then
  265.             ERR.Raise 76
  266.         Else
  267.             ERR.Raise 75
  268.         End If
  269.     End If
  270. End Sub

  271. ' (VB-Overwrite)
  272. Public Function FileLen(ByVal PathName As String) As Variant
  273.     Const INVALID_HANDLE_VALUE As Long = (-1), INVALID_FILE_SIZE As Long = (-1)
  274.     Const GENERIC_READ As Long = &H80000000, FILE_SHARE_READ As Long = &H1, OPEN_EXISTING As Long = 3, FILE_FLAG_SEQUENTIAL_SCAN As Long = &H8000000
  275.     Dim hFile As Long
  276.     If Left$(PathName, 2) = "\\" Then PathName = "UNC\" & Mid$(PathName, 3)
  277.     hFile = CreateFile(StrPtr("\\?\" & PathName), GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, 0)
  278.     If hFile <> INVALID_HANDLE_VALUE Then
  279.         Dim LoDWord As Long, HiDWord As Long
  280.         LoDWord = GetFileSize(hFile, HiDWord)
  281.         CloseHandle hFile
  282.         If LoDWord <> INVALID_FILE_SIZE Then
  283.             FileLen = CDec(0)
  284.             VarDecFromI8 LoDWord, HiDWord, FileLen
  285.         Else
  286.             FileLen = Null
  287.         End If
  288.     Else
  289.         ERR.Raise Number:=53, Description:="File not found: '" & PathName & "'"
  290.     End If
  291. End Function

  292. ' (VB-Overwrite)
  293. Public Function FileDateTime(ByVal PathName As String) As Date
  294.     Const INVALID_HANDLE_VALUE As Long = (-1)
  295.     Const GENERIC_READ As Long = &H80000000, FILE_SHARE_READ As Long = &H1, OPEN_EXISTING As Long = 3, FILE_FLAG_SEQUENTIAL_SCAN As Long = &H8000000
  296.     Dim hFile As Long
  297.     If Left$(PathName, 2) = "\\" Then PathName = "UNC\" & Mid$(PathName, 3)
  298.     hFile = CreateFile(StrPtr("\\?\" & PathName), GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, 0)
  299.     If hFile <> INVALID_HANDLE_VALUE Then
  300.         Dim FT(0 To 1) As FILETIME, st As SYSTEMTIME
  301.         GetFileTime hFile, 0, 0, VarPtr(FT(0))
  302.         FileTimeToLocalFileTime VarPtr(FT(0)), VarPtr(FT(1))
  303.         FileTimeToSystemTime VarPtr(FT(1)), VarPtr(st)
  304.         FileDateTime = DateSerial(st.wYear, st.wMonth, st.wDay) + TimeSerial(st.wHour, st.wMinute, st.wSecond)
  305.         CloseHandle hFile
  306.     Else
  307.         ERR.Raise Number:=53, Description:="File not found: '" & PathName & "'"
  308.     End If
  309. End Function

  310. ' (VB-Overwrite)
  311. Public Function Command$()
  312.     If InIDE() = False Then
  313.         SysReAllocString VarPtr(Command$), PathGetArgs(GetCommandLine())
  314.         Command$ = LTrim$(Command$)
  315.     Else
  316.         Command$ = VBA.Command$()
  317.     End If
  318. End Function

  319. Public Function FileExists(ByVal PathName As String) As Boolean
  320.     On Error Resume Next
  321.     Dim Attributes As VbFileAttribute, ErrVal As Long
  322.     Attributes = GetAttr(PathName)
  323.     ErrVal = ERR.Number
  324.     On Error GoTo 0
  325.     If (Attributes And (vbDirectory Or vbVolume)) = 0 And ErrVal = 0 Then FileExists = True
  326. End Function

  327. Public Function AppPath() As String
  328.     If InIDE() = False Then
  329.         Const MAX_PATH_W As Long = 32767
  330.         Dim Buffer As String, RetVal As Long
  331.         Buffer = String(MAX_PATH, vbNullChar)
  332.         RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH)
  333.         If RetVal = MAX_PATH Then                                               ' Path > MAX_PATH
  334.             Buffer = String(MAX_PATH_W, vbNullChar)
  335.             RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH_W)
  336.         End If
  337.         If RetVal > 0 Then
  338.             Buffer = Left$(Buffer, RetVal)
  339.             AppPath = Left$(Buffer, InStrRev(Buffer, "\"))
  340.         Else
  341.             AppPath = App.Path & IIf(Right$(App.Path, 1) = "\", "", "\")
  342.         End If
  343.     Else
  344.         AppPath = App.Path & IIf(Right$(App.Path, 1) = "\", "", "\")
  345.     End If
  346. End Function

  347. Public Function AppEXEName() As String
  348.     If InIDE() = False Then
  349.         Const MAX_PATH_W As Long = 32767
  350.         Dim Buffer As String, RetVal As Long
  351.         Buffer = String(MAX_PATH, vbNullChar)
  352.         RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH)
  353.         If RetVal = MAX_PATH Then                                               ' Path > MAX_PATH
  354.             Buffer = String(MAX_PATH_W, vbNullChar)
  355.             RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH_W)
  356.         End If
  357.         If RetVal > 0 Then
  358.             Buffer = Left$(Buffer, RetVal)
  359.             Buffer = Right$(Buffer, Len(Buffer) - InStrRev(Buffer, "\"))
  360.             AppEXEName = Left$(Buffer, InStrRev(Buffer, ".") - 1)
  361.         Else
  362.             AppEXEName = App.EXEName
  363.         End If
  364.     Else
  365.         AppEXEName = App.EXEName
  366.     End If
  367. End Function

  368. Public Function AppMajor() As Integer
  369.     If InIDE() = False Then
  370.         With GetAppVersionInfo()
  371.             AppMajor = .dwFileVersionMSHi
  372.         End With
  373.     Else
  374.         AppMajor = App.Major
  375.     End If
  376. End Function

  377. Public Function AppMinor() As Integer
  378.     If InIDE() = False Then
  379.         With GetAppVersionInfo()
  380.             AppMinor = .dwFileVersionMSLo
  381.         End With
  382.     Else
  383.         AppMinor = App.Minor
  384.     End If
  385. End Function

  386. Public Function AppRevision() As Integer
  387.     If InIDE() = False Then
  388.         With GetAppVersionInfo()
  389.             AppRevision = .dwFileVersionLSLo
  390.         End With
  391.     Else
  392.         AppRevision = App.Revision
  393.     End If
  394. End Function

  395. Private Function GetAppVersionInfo() As VS_FIXEDFILEINFO
  396.     Static Done As Boolean, Value As VS_FIXEDFILEINFO
  397.     If Done = False Then
  398.         Const MAX_PATH_W As Long = 32767
  399.         Dim Buffer As String, RetVal As Long
  400.         Buffer = String(MAX_PATH, vbNullChar)
  401.         RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH)
  402.         If RetVal = MAX_PATH Then                                               ' Path > MAX_PATH
  403.             Buffer = String(MAX_PATH_W, vbNullChar)
  404.             RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH_W)
  405.         End If
  406.         If RetVal > 0 Then
  407.             Dim ImagePath As String, Length As Long
  408.             ImagePath = Left$(Buffer, RetVal)
  409.             Length = GetFileVersionInfoSize(StrPtr(ImagePath), 0)
  410.             If Length > 0 Then
  411.                 Dim DataBuffer() As Byte
  412.                 ReDim DataBuffer(0 To (Length - 1)) As Byte
  413.                 If GetFileVersionInfo(StrPtr(ImagePath), 0, Length, VarPtr(DataBuffer(0))) <> 0 Then
  414.                     Dim hData As Long
  415.                     If VerQueryValue(VarPtr(DataBuffer(0)), StrPtr("\"), hData, Length) <> 0 Then
  416.                         If hData <> 0 Then CopyMemory Value, ByVal hData, LenB(Value)
  417.                     End If
  418.                 End If
  419.             End If
  420.         End If
  421.         Done = True
  422.     End If
  423.     LSet GetAppVersionInfo = Value
  424. End Function

  425. Public Function GetClipboardText() As String
  426.     Const CF_UNICODETEXT As Long = 13
  427.     Dim lpText As Long, Length As Long
  428.     Dim hMem As Long, lpMem As Long
  429.     If OpenClipboard(0) <> 0 Then
  430.         If IsClipboardFormatAvailable(CF_UNICODETEXT) <> 0 Then
  431.             lpText = GetClipboardData(CF_UNICODETEXT)
  432.             If lpText <> 0 Then
  433.                 Length = GlobalSize(lpText)
  434.                 If Length > 0 Then
  435.                     lpMem = GlobalLock(lpText)
  436.                     If lpMem <> 0 Then
  437.                         GetClipboardText = String((Length \ 2) - 1, vbNullChar)
  438.                         CopyMemory ByVal StrPtr(GetClipboardText), ByVal lpMem, Length
  439.                         GlobalUnlock lpMem
  440.                     End If
  441.                 End If
  442.             End If
  443.         End If
  444.         CloseClipboard
  445.     End If
  446. End Function

  447. Public Sub SetClipboardText(ByRef Text As String)
  448.     Const CF_UNICODETEXT As Long = 13
  449.     Const GMEM_MOVEABLE As Long = &H2
  450.     Dim Buffer As String, Length As Long
  451.     Dim hMem As Long, lpMem As Long
  452.     If OpenClipboard(0) <> 0 Then
  453.         EmptyClipboard
  454.         Buffer = Text & vbNullChar
  455.         Length = LenB(Buffer)
  456.         hMem = GlobalAlloc(GMEM_MOVEABLE, Length)
  457.         If hMem <> 0 Then
  458.             lpMem = GlobalLock(hMem)
  459.             If lpMem <> 0 Then
  460.                 CopyMemory ByVal lpMem, ByVal StrPtr(Buffer), Length
  461.                 GlobalUnlock hMem
  462.                 SetClipboardData CF_UNICODETEXT, hMem
  463.             End If
  464.         End If
  465.         CloseClipboard
  466.     End If
  467. End Sub

  468. Public Function AccelCharCode(ByVal Caption As String) As Integer
  469.     If Caption = vbNullString Then Exit Function
  470.     Dim Pos As Long, Length As Long
  471.     Length = Len(Caption)
  472.     Pos = Length
  473.     Do
  474.         If Mid$(Caption, Pos, 1) = "&" And Pos < Length Then
  475.             AccelCharCode = Asc(UCase$(Mid$(Caption, Pos + 1, 1)))
  476.             If Pos > 1 Then
  477.                 If Mid$(Caption, Pos - 1, 1) = "&" Then AccelCharCode = 0
  478.             Else
  479.                 If AccelCharCode = vbKeyUp Then AccelCharCode = 0
  480.             End If
  481.             If AccelCharCode <> 0 Then Exit Do
  482.         End If
  483.         Pos = Pos - 1
  484.     Loop Until Pos = 0
  485. End Function

  486. Public Function ProperControlName(ByVal Control As VB.Control) As String
  487.     Dim Index As Long
  488.     On Error Resume Next
  489.     Index = Control.Index
  490.     If ERR.Number <> 0 Or Index < 0 Then ProperControlName = Control.Name Else ProperControlName = Control.Name & "(" & Index & ")"
  491.     On Error GoTo 0
  492. End Function

  493. Public Function GetTopUserControl(ByVal UserControl As Object) As VB.UserControl
  494.     If UserControl Is Nothing Then Exit Function
  495.     Dim TopUserControl As VB.UserControl, TempUserControl As VB.UserControl
  496.     CopyMemory TempUserControl, ObjPtr(UserControl), 4
  497.     Set TopUserControl = TempUserControl
  498.     CopyMemory TempUserControl, 0&, 4
  499.     With TopUserControl
  500.         If .ParentControls.Count > 0 Then
  501.             Dim OldParentControlsType As VBRUN.ParentControlsType
  502.             OldParentControlsType = .ParentControls.ParentControlsType
  503.             .ParentControls.ParentControlsType = vbExtender
  504.             If TypeOf .ParentControls(0) Is VB.VBControlExtender Then
  505.                 .ParentControls.ParentControlsType = vbNoExtender
  506.                 CopyMemory TempUserControl, ObjPtr(.ParentControls(0)), 4
  507.                 Set TopUserControl = TempUserControl
  508.                 CopyMemory TempUserControl, 0&, 4
  509.                 Dim TempParentControlsType As VBRUN.ParentControlsType
  510.                 Do
  511.                     With TopUserControl
  512.                         If .ParentControls.Count = 0 Then Exit Do
  513.                         TempParentControlsType = .ParentControls.ParentControlsType
  514.                         .ParentControls.ParentControlsType = vbExtender
  515.                         If TypeOf .ParentControls(0) Is VB.VBControlExtender Then
  516.                             .ParentControls.ParentControlsType = vbNoExtender
  517.                             CopyMemory TempUserControl, ObjPtr(.ParentControls(0)), 4
  518.                             Set TopUserControl = TempUserControl
  519.                             CopyMemory TempUserControl, 0&, 4
  520.                             .ParentControls.ParentControlsType = TempParentControlsType
  521.                         Else
  522.                             .ParentControls.ParentControlsType = TempParentControlsType
  523.                             Exit Do
  524.                         End If
  525.                     End With
  526.                 Loop
  527.             End If
  528.             .ParentControls.ParentControlsType = OldParentControlsType
  529.         End If
  530.     End With
  531.     Set GetTopUserControl = TopUserControl
  532. End Function

  533. Public Function MousePointerID(ByVal MousePointer As Integer) As Long
  534.     Select Case MousePointer
  535.     Case vbArrow
  536.         Const IDC_ARROW As Long = 32512
  537.         MousePointerID = IDC_ARROW
  538.     Case vbCrosshair
  539.         Const IDC_CROSS As Long = 32515
  540.         MousePointerID = IDC_CROSS
  541.     Case vbIbeam
  542.         Const IDC_IBEAM As Long = 32513
  543.         MousePointerID = IDC_IBEAM
  544.     Case vbIconPointer                                                          ' Obselete, replaced Icon with Hand
  545.         Const IDC_HAND As Long = 32649
  546.         MousePointerID = IDC_HAND
  547.     Case vbSizePointer, vbSizeAll
  548.         Const IDC_SIZEALL As Long = 32646
  549.         MousePointerID = IDC_SIZEALL
  550.     Case vbSizeNESW
  551.         Const IDC_SIZENESW As Long = 32643
  552.         MousePointerID = IDC_SIZENESW
  553.     Case vbSizeNS
  554.         Const IDC_SIZENS As Long = 32645
  555.         MousePointerID = IDC_SIZENS
  556.     Case vbSizeNWSE
  557.         Const IDC_SIZENWSE As Long = 32642
  558.         MousePointerID = IDC_SIZENWSE
  559.     Case vbSizeWE
  560.         Const IDC_SIZEWE As Long = 32644
  561.         MousePointerID = IDC_SIZEWE
  562.     Case vbUpArrow
  563.         Const IDC_UPARROW As Long = 32516
  564.         MousePointerID = IDC_UPARROW
  565.     Case vbHourglass
  566.         Const IDC_WAIT As Long = 32514
  567.         MousePointerID = IDC_WAIT
  568.     Case vbNoDrop
  569.         Const IDC_NO As Long = 32648
  570.         MousePointerID = IDC_NO
  571.     Case vbArrowHourglass
  572.         Const IDC_APPSTARTING As Long = 32650
  573.         MousePointerID = IDC_APPSTARTING
  574.     Case vbArrowQuestion
  575.         Const IDC_HELP As Long = 32651
  576.         MousePointerID = IDC_HELP
  577.     Case 16
  578.         Const IDC_WAITCD As Long = 32663                                        ' Undocumented
  579.         MousePointerID = IDC_WAITCD
  580.     End Select
  581. End Function

  582. Public Function OLEFontIsEqual(ByVal Font As StdFont, ByVal FontOther As StdFont) As Boolean
  583.     If Font Is Nothing Then
  584.         If FontOther Is Nothing Then OLEFontIsEqual = True
  585.     ElseIf FontOther Is Nothing Then
  586.         If Font Is Nothing Then OLEFontIsEqual = True
  587.     Else
  588.         If Font.Name = FontOther.Name And Font.Size = FontOther.Size And Font.Charset = FontOther.Charset And Font.Weight = FontOther.Weight And _
  589.             Font.Underline = FontOther.Underline And Font.Italic = FontOther.Italic And Font.Strikethrough = FontOther.Strikethrough Then
  590.             OLEFontIsEqual = True
  591.         End If
  592.     End If
  593. End Function

  594. Public Function CreateGDIFontFromOLEFont(ByVal Font As StdFont) As Long
  595.     Dim LF As LOGFONT, FontName As String
  596.     With LF
  597.         FontName = Left$(Font.Name, LF_FACESIZE)
  598.         CopyMemory .LFFaceName(0), ByVal StrPtr(FontName), LenB(FontName)
  599.         .LFHeight = -MulDiv(CLng(Font.Size), DPI_Y(), 72)
  600.         If Font.Bold = True Then .LFWeight = FW_BOLD Else .LFWeight = FW_NORMAL
  601.         If Font.Italic = True Then .LFItalic = 1 Else .LFItalic = 0
  602.         If Font.Strikethrough = True Then .LFStrikeOut = 1 Else .LFStrikeOut = 0
  603.         If Font.Underline = True Then .LFUnderline = 1 Else .LFUnderline = 0
  604.         .LFQuality = DEFAULT_QUALITY
  605.         .LFCharset = CByte(Font.Charset And &HFF)
  606.     End With
  607.     CreateGDIFontFromOLEFont = CreateFontIndirect(LF)
  608. End Function

  609. Public Function CloneOLEFont(ByVal Font As IFont) As StdFont
  610.     Font.Clone CloneOLEFont
  611. End Function

  612. Public Function GDIFontFromOLEFont(ByVal Font As IFont) As Long
  613.     GDIFontFromOLEFont = Font.hFont
  614. End Function

  615. Public Function GetNumberGroupDigit() As String
  616.     GetNumberGroupDigit = Mid$(FormatNumber(1000, 0, , , vbTrue), 2, 1)
  617.     If GetNumberGroupDigit = "0" Then GetNumberGroupDigit = vbNullString
  618. End Function

  619. Public Function GetDecimalChar() As String
  620.     GetDecimalChar = Mid$(CStr(1.1), 2, 1)
  621. End Function

  622. Public Function IsFormLoaded(ByVal FormName As String) As Boolean
  623.     Dim i As Integer
  624.     For i = 0 To Forms.Count - 1
  625.         If StrComp(Forms(i).Name, FormName, vbTextCompare) = 0 Then
  626.             IsFormLoaded = True
  627.             Exit For
  628.         End If
  629.     Next i
  630. End Function

  631. Public Function GetWindowTitle(ByVal hwnd As Long) As String
  632.     Dim Buffer As String
  633.     Buffer = String(GetWindowTextLength(hwnd) + 1, vbNullChar)
  634.     GetWindowText hwnd, StrPtr(Buffer), Len(Buffer)
  635.     GetWindowTitle = Left$(Buffer, Len(Buffer) - 1)
  636. End Function

  637. Public Function GetWindowClassName(ByVal hwnd As Long) As String
  638.     Dim Buffer As String, RetVal As Long
  639.     Buffer = String(256, vbNullChar)
  640.     RetVal = GetClassName(hwnd, StrPtr(Buffer), Len(Buffer))
  641.     If RetVal <> 0 Then GetWindowClassName = Left$(Buffer, RetVal)
  642. End Function

  643. Public Function GetFormTitleBarHeight(ByVal Form As VB.Form) As Single
  644.     Const SM_CYCAPTION As Long = 4, SM_CYMENU As Long = 15
  645.     Const SM_CYSIZEFRAME As Long = 33, SM_CYFIXEDFRAME As Long = 8
  646.     Dim cy As Long
  647.     cy = GetSystemMetrics(SM_CYCAPTION)
  648.     If GetMenu(Form.hwnd) <> 0 Then cy = cy + GetSystemMetrics(SM_CYMENU)
  649.     Select Case Form.BorderStyle
  650.     Case vbSizable, vbSizableToolWindow
  651.         cy = cy + GetSystemMetrics(SM_CYSIZEFRAME)
  652.     Case vbFixedSingle, vbFixedDialog, vbFixedToolWindow
  653.         cy = cy + GetSystemMetrics(SM_CYFIXEDFRAME)
  654.     End Select
  655.     If cy > 0 Then GetFormTitleBarHeight = Form.ScaleY(cy, vbPixels, Form.ScaleMode)
  656. End Function

  657. Public Function GetFormNonScaleHeight(ByVal Form As VB.Form) As Single
  658.     Const SM_CYCAPTION As Long = 4, SM_CYMENU As Long = 15
  659.     Const SM_CYSIZEFRAME As Long = 33, SM_CYFIXEDFRAME As Long = 8
  660.     Dim cy As Long
  661.     cy = GetSystemMetrics(SM_CYCAPTION)
  662.     If GetMenu(Form.hwnd) <> 0 Then cy = cy + GetSystemMetrics(SM_CYMENU)
  663.     Select Case Form.BorderStyle
  664.     Case vbSizable, vbSizableToolWindow
  665.         cy = cy + (GetSystemMetrics(SM_CYSIZEFRAME) * 2)
  666.     Case vbFixedSingle, vbFixedDialog, vbFixedToolWindow
  667.         cy = cy + (GetSystemMetrics(SM_CYFIXEDFRAME) * 2)
  668.     End Select
  669.     If cy > 0 Then GetFormNonScaleHeight = Form.ScaleY(cy, vbPixels, Form.ScaleMode)
  670. End Function

  671. Public Sub SetWindowRedraw(ByVal hwnd As Long, ByVal Enabled As Boolean)
  672.     Const WM_SETREDRAW As Long = &HB
  673.     SendMessage hwnd, WM_SETREDRAW, IIf(Enabled = True, 1, 0), ByVal 0&
  674.     If Enabled = True Then
  675.         Const RDW_UPDATENOW As Long = &H100, RDW_INVALIDATE As Long = &H1, RDW_ERASE As Long = &H4, RDW_ALLCHILDREN As Long = &H80
  676.         RedrawWindow hwnd, 0, 0, RDW_UPDATENOW Or RDW_INVALIDATE Or RDW_ERASE Or RDW_ALLCHILDREN
  677.     End If
  678. End Sub

  679. Public Function GetWindowsDir() As String
  680.     Static Done As Boolean, Value As String
  681.     If Done = False Then
  682.         Dim Buffer As String
  683.         Buffer = String(MAX_PATH, vbNullChar)
  684.         If GetSystemWindowsDirectory(StrPtr(Buffer), MAX_PATH) <> 0 Then
  685.             Value = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
  686.             Value = Value & IIf(Right$(Value, 1) = "\", "", "\")
  687.         End If
  688.         Done = True
  689.     End If
  690.     GetWindowsDir = Value
  691. End Function

  692. Public Function GetSystemDir() As String
  693.     Static Done As Boolean, Value As String
  694.     If Done = False Then
  695.         Dim Buffer As String
  696.         Buffer = String(MAX_PATH, vbNullChar)
  697.         If GetSystemDirectory(StrPtr(Buffer), MAX_PATH) <> 0 Then
  698.             Value = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
  699.             Value = Value & IIf(Right$(Value, 1) = "\", "", "\")
  700.         End If
  701.         Done = True
  702.     End If
  703.     GetSystemDir = Value
  704. End Function

  705. Public Function GetShiftStateFromParam(ByVal wParam As Long) As ShiftConstants
  706.     Const MK_SHIFT As Long = &H4, MK_CONTROL As Long = &H8
  707.     If (wParam And MK_SHIFT) = MK_SHIFT Then GetShiftStateFromParam = vbShiftMask
  708.     If (wParam And MK_CONTROL) = MK_CONTROL Then GetShiftStateFromParam = GetShiftStateFromParam Or vbCtrlMask
  709.     If GetKeyState(vbKeyMenu) < 0 Then GetShiftStateFromParam = GetShiftStateFromParam Or vbAltMask
  710. End Function

  711. Public Function GetMouseStateFromParam(ByVal wParam As Long) As MouseButtonConstants
  712.     Const MK_LBUTTON As Long = &H1, MK_RBUTTON As Long = &H2, MK_MBUTTON As Long = &H10
  713.     If (wParam And MK_LBUTTON) = MK_LBUTTON Then GetMouseStateFromParam = vbLeftButton
  714.     If (wParam And MK_RBUTTON) = MK_RBUTTON Then GetMouseStateFromParam = GetMouseStateFromParam Or vbRightButton
  715.     If (wParam And MK_MBUTTON) = MK_MBUTTON Then GetMouseStateFromParam = GetMouseStateFromParam Or vbMiddleButton
  716. End Function

  717. Public Function GetShiftStateFromMsg() As ShiftConstants
  718.     If GetKeyState(vbKeyShift) < 0 Then GetShiftStateFromMsg = vbShiftMask
  719.     If GetKeyState(vbKeyControl) < 0 Then GetShiftStateFromMsg = GetShiftStateFromMsg Or vbCtrlMask
  720.     If GetKeyState(vbKeyMenu) < 0 Then GetShiftStateFromMsg = GetShiftStateFromMsg Or vbAltMask
  721. End Function

  722. Public Function GetMouseStateFromMsg() As MouseButtonConstants
  723.     If GetKeyState(vbLeftButton) < 0 Then GetMouseStateFromMsg = vbLeftButton
  724.     If GetKeyState(vbRightButton) < 0 Then GetMouseStateFromMsg = GetMouseStateFromMsg Or vbRightButton
  725.     If GetKeyState(vbMiddleButton) < 0 Then GetMouseStateFromMsg = GetMouseStateFromMsg Or vbMiddleButton
  726. End Function

  727. Public Function GetShiftState() As ShiftConstants
  728.     GetShiftState = (-vbShiftMask * KeyPressed(vbKeyShift))
  729.     GetShiftState = GetShiftState Or (-vbCtrlMask * KeyPressed(vbKeyControl))
  730.     GetShiftState = GetShiftState Or (-vbAltMask * KeyPressed(vbKeyMenu))
  731. End Function

  732. Public Function GetMouseState() As MouseButtonConstants
  733.     Const SM_SWAPBUTTON As Long = 23
  734.     ' GetAsyncKeyState requires a mapping of physical mouse buttons to logical mouse buttons.
  735.     GetMouseState = (-vbLeftButton * KeyPressed(IIf(GetSystemMetrics(SM_SWAPBUTTON) = 0, vbLeftButton, vbRightButton)))
  736.     GetMouseState = GetMouseState Or (-vbRightButton * KeyPressed(IIf(GetSystemMetrics(SM_SWAPBUTTON) = 0, vbRightButton, vbLeftButton)))
  737.     GetMouseState = GetMouseState Or (-vbMiddleButton * KeyPressed(vbMiddleButton))
  738. End Function

  739. Public Function KeyToggled(ByVal KeyCode As KeyCodeConstants) As Boolean
  740.     KeyToggled = CBool(LoByte(GetKeyState(KeyCode)) = 1)
  741. End Function

  742. Public Function KeyPressed(ByVal KeyCode As KeyCodeConstants) As Boolean
  743.     KeyPressed = CBool((GetAsyncKeyState(KeyCode) And &H8000&) = &H8000&)
  744. End Function

  745. Public Function InIDE(Optional ByRef b As Boolean = True) As Boolean
  746.     If b = True Then Debug.Assert Not InIDE(InIDE) Else b = True
  747. End Function

  748. Public Function PtrToObj(ByVal ObjectPointer As Long) As Object
  749.     Dim TempObj As Object
  750.     CopyMemory TempObj, ObjectPointer, 4
  751.     Set PtrToObj = TempObj
  752.     CopyMemory TempObj, 0&, 4
  753. End Function

  754. Public Function ProcPtr(ByVal Address As Long) As Long
  755.     ProcPtr = Address
  756. End Function

  757. Public Function LoByte(ByVal Word As Integer) As Byte
  758.     LoByte = Word And &HFF
  759. End Function

  760. Public Function HiByte(ByVal Word As Integer) As Byte
  761.     HiByte = (Word And &HFF00&) \ &H100
  762. End Function

  763. Public Function MakeWord(ByVal LoByte As Byte, ByVal HiByte As Byte) As Integer
  764.     If (HiByte And &H80) <> 0 Then
  765.         MakeWord = ((HiByte * &H100&) Or LoByte) Or &HFFFF0000
  766.     Else
  767.         MakeWord = (HiByte * &H100) Or LoByte
  768.     End If
  769. End Function

  770. Public Function LoWord(ByVal DWord As Long) As Integer
  771.     If DWord And &H8000& Then
  772.         LoWord = DWord Or &HFFFF0000
  773.     Else
  774.         LoWord = DWord And &HFFFF&
  775.     End If
  776. End Function

  777. Public Function HiWord(ByVal DWord As Long) As Integer
  778.     HiWord = (DWord And &HFFFF0000) \ &H10000
  779. End Function

  780. Public Function MakeDWord(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long
  781.     MakeDWord = (CLng(HiWord) * &H10000) Or (LoWord And &HFFFF&)
  782. End Function

  783. Public Function Get_X_lParam(ByVal lParam As Long) As Long
  784.     Get_X_lParam = lParam And &H7FFF&
  785.     If lParam And &H8000& Then Get_X_lParam = Get_X_lParam Or &HFFFF8000
  786. End Function

  787. Public Function Get_Y_lParam(ByVal lParam As Long) As Long
  788.     Get_Y_lParam = (lParam And &H7FFF0000) \ &H10000
  789.     If lParam And &H80000000 Then Get_Y_lParam = Get_Y_lParam Or &HFFFF8000
  790. End Function

  791. Public Function UTF16_To_UTF8(ByRef Source As String) As Byte()
  792.     Const CP_UTF8 As Long = 65001
  793.     Dim Length As Long, Pointer As Long, Size As Long
  794.     Length = Len(Source)
  795.     Pointer = StrPtr(Source)
  796.     Size = WideCharToMultiByte(CP_UTF8, 0, Pointer, Length, 0, 0, 0, 0)
  797.     If Size > 0 Then
  798.         Dim Buffer() As Byte
  799.         ReDim Buffer(0 To Size - 1) As Byte
  800.         WideCharToMultiByte CP_UTF8, 0, Pointer, Length, VarPtr(Buffer(0)), Size, 0, 0
  801.         UTF16_To_UTF8 = Buffer()
  802.     End If
  803. End Function

  804. Public Function UTF8_To_UTF16(ByRef Source() As Byte) As String
  805.     If (0 / 1) + (Not Not Source()) = 0 Then Exit Function
  806.     Const CP_UTF8 As Long = 65001
  807.     Dim Size As Long, Pointer As Long, Length As Long
  808.     Size = UBound(Source) - LBound(Source) + 1
  809.     Pointer = VarPtr(Source(LBound(Source)))
  810.     Length = MultiByteToWideChar(CP_UTF8, 0, Pointer, Size, 0, 0)
  811.     If Length > 0 Then
  812.         UTF8_To_UTF16 = Space$(Length)
  813.         MultiByteToWideChar CP_UTF8, 0, Pointer, Size, StrPtr(UTF8_To_UTF16), Length
  814.     End If
  815. End Function

  816. Public Function StrToVar(ByVal Text As String) As Variant
  817.     If Text = vbNullString Then
  818.         StrToVar = Empty
  819.     Else
  820.         Dim b() As Byte
  821.         b() = Text
  822.         StrToVar = b()
  823.     End If
  824. End Function

  825. Public Function VarToStr(ByVal Bytes As Variant) As String
  826.     If IsEmpty(Bytes) Then
  827.         VarToStr = vbNullString
  828.     Else
  829.         Dim b() As Byte
  830.         b() = Bytes
  831.         VarToStr = b()
  832.     End If
  833. End Function

  834. Public Function UnsignedAdd(ByVal Start As Long, ByVal Incr As Long) As Long
  835.     UnsignedAdd = ((Start Xor &H80000000) + Incr) Xor &H80000000
  836. End Function

  837. Public Function CUIntToInt(ByVal Value As Long) As Integer
  838.     Const OFFSET_2 As Long = 65536
  839.     Const MAXINT_2 As Integer = 32767
  840.     If Value < 0 Or Value >= OFFSET_2 Then ERR.Raise 6
  841.     If Value <= MAXINT_2 Then
  842.         CUIntToInt = Value
  843.     Else
  844.         CUIntToInt = Value - OFFSET_2
  845.     End If
  846. End Function

  847. Public Function CIntToUInt(ByVal Value As Integer) As Long
  848.     Const OFFSET_2 As Long = 65536
  849.     If Value < 0 Then
  850.         CIntToUInt = Value + OFFSET_2
  851.     Else
  852.         CIntToUInt = Value
  853.     End If
  854. End Function

  855. Public Function CULngToLng(ByVal Value As Double) As Long
  856.     Const OFFSET_4 As Double = 4294967296#
  857.     Const MAXINT_4 As Long = 2147483647
  858.     If Value < 0 Or Value >= OFFSET_4 Then ERR.Raise 6
  859.     If Value <= MAXINT_4 Then
  860.         CULngToLng = Value
  861.     Else
  862.         CULngToLng = Value - OFFSET_4
  863.     End If
  864. End Function

  865. Public Function CLngToULng(ByVal Value As Long) As Double
  866.     Const OFFSET_4 As Double = 4294967296#
  867.     If Value < 0 Then
  868.         CLngToULng = Value + OFFSET_4
  869.     Else
  870.         CLngToULng = Value
  871.     End If
  872. End Function

  873. Public Function DPI_X() As Long
  874.     Const LOGPIXELSX As Long = 88
  875.     Dim hDCScreen As Long
  876.     hDCScreen = GetDC(0)
  877.     If hDCScreen <> 0 Then
  878.         DPI_X = GetDeviceCaps(hDCScreen, LOGPIXELSX)
  879.         ReleaseDC 0, hDCScreen
  880.     End If
  881. End Function

  882. Public Function DPI_Y() As Long
  883.     Const LOGPIXELSY As Long = 90
  884.     Dim hDCScreen As Long
  885.     hDCScreen = GetDC(0)
  886.     If hDCScreen <> 0 Then
  887.         DPI_Y = GetDeviceCaps(hDCScreen, LOGPIXELSY)
  888.         ReleaseDC 0, hDCScreen
  889.     End If
  890. End Function

  891. Public Function DPICorrectionFactor() As Single
  892.     Static Done As Boolean, Value As Single
  893.     If Done = False Then
  894.         Value = ((96 / DPI_X()) * 15) / Screen.TwipsPerPixelX
  895.         Done = True
  896.     End If
  897.     ' Returns exactly 1 when no corrections are required.
  898.     DPICorrectionFactor = Value
  899. End Function

  900. Public Function CHimetricToPixel_X(ByVal Width As Long) As Long
  901.     Const HIMETRIC_PER_INCH As Long = 2540
  902.     CHimetricToPixel_X = (Width * DPI_X()) / HIMETRIC_PER_INCH
  903. End Function

  904. Public Function CHimetricToPixel_Y(ByVal Height As Long) As Long
  905.     Const HIMETRIC_PER_INCH As Long = 2540
  906.     CHimetricToPixel_Y = (Height * DPI_Y()) / HIMETRIC_PER_INCH
  907. End Function

  908. Public Function PixelsPerDIP_X() As Single
  909.     Static Done As Boolean, Value As Single
  910.     If Done = False Then
  911.         Value = (DPI_X() / 96)
  912.         Done = True
  913.     End If
  914.     PixelsPerDIP_X = Value
  915. End Function

  916. Public Function PixelsPerDIP_Y() As Single
  917.     Static Done As Boolean, Value As Single
  918.     If Done = False Then
  919.         Value = (DPI_Y() / 96)
  920.         Done = True
  921.     End If
  922.     PixelsPerDIP_Y = Value
  923. End Function

  924. Public Function WinColor(ByVal Color As Long, Optional ByVal hPal As Long) As Long
  925.     If OleTranslateColor(Color, hPal, WinColor) <> 0 Then WinColor = -1
  926. End Function

  927. Public Function PictureFromByteStream(ByRef ByteStream As Variant) As IPictureDisp
  928.     Const GMEM_MOVEABLE As Long = &H2
  929.     Dim IID As CLSID, Stream As IUnknown, NewPicture As IPicture
  930.     Dim b() As Byte, ByteCount As Long
  931.     Dim hMem As Long, lpMem As Long
  932.     With IID
  933.         .Data1 = &H7BF80980
  934.         .Data2 = &HBF32
  935.         .Data3 = &H101A
  936.         .Data4(0) = &H8B
  937.         .Data4(1) = &HBB
  938.         .Data4(3) = &HAA
  939.         .Data4(5) = &H30
  940.         .Data4(6) = &HC
  941.         .Data4(7) = &HAB
  942.     End With
  943.     If VarType(ByteStream) = (vbArray + vbByte) Then
  944.         b() = ByteStream
  945.         ByteCount = (UBound(b()) - LBound(b())) + 1
  946.         hMem = GlobalAlloc(GMEM_MOVEABLE, ByteCount)
  947.         If hMem <> 0 Then
  948.             lpMem = GlobalLock(hMem)
  949.             If lpMem <> 0 Then
  950.                 CopyMemory ByVal lpMem, b(LBound(b())), ByteCount
  951.                 GlobalUnlock hMem
  952.                 If CreateStreamOnHGlobal(hMem, 1, Stream) = 0 Then
  953.                     If OleLoadPicture(Stream, ByteCount, 0, IID, NewPicture) = 0 Then Set PictureFromByteStream = NewPicture
  954.                 End If
  955.             End If
  956.         End If
  957.     End If
  958. End Function

  959. Public Function PictureFromPath(ByVal PathName As String) As IPictureDisp
  960.     Dim IID As CLSID, NewPicture As IPicture
  961.     With IID
  962.         .Data1 = &H7BF80980
  963.         .Data2 = &HBF32
  964.         .Data3 = &H101A
  965.         .Data4(0) = &H8B
  966.         .Data4(1) = &HBB
  967.         .Data4(3) = &HAA
  968.         .Data4(5) = &H30
  969.         .Data4(6) = &HC
  970.         .Data4(7) = &HAB
  971.     End With
  972.     If OleLoadPicturePath(StrPtr(PathName), 0, 0, 0, IID, NewPicture) = 0 Then Set PictureFromPath = NewPicture
  973. End Function

  974. Public Function PictureFromHandle(ByVal Handle As Long, ByVal PicType As VBRUN.PictureTypeConstants) As IPictureDisp
  975.     If Handle = 0 Then Exit Function
  976.     Dim PICD As PICTDESC, IID As CLSID, NewPicture As IPicture
  977.     With PICD
  978.         .cbSizeOfStruct = LenB(PICD)
  979.         .PicType = PicType
  980.         .hImage = Handle
  981.     End With
  982.     With IID
  983.         .Data1 = &H7BF80980
  984.         .Data2 = &HBF32
  985.         .Data3 = &H101A
  986.         .Data4(0) = &H8B
  987.         .Data4(1) = &HBB
  988.         .Data4(3) = &HAA
  989.         .Data4(5) = &H30
  990.         .Data4(6) = &HC
  991.         .Data4(7) = &HAB
  992.     End With
  993.     If OleCreatePictureIndirect(PICD, IID, 1, NewPicture) = 0 Then Set PictureFromHandle = NewPicture
  994. End Function

  995. Public Function BitmapHandleFromPicture(ByVal Picture As IPictureDisp, Optional ByVal BackColor As OLE_COLOR) As Long
  996.     If Picture Is Nothing Then Exit Function
  997.     With Picture
  998.         If .Handle <> 0 Then
  999.             Dim hDCScreen As Long, hDC As Long, hBmp As Long, hBmpOld As Long
  1000.             Dim cx As Long, cy As Long, Brush As Long
  1001.             cx = CHimetricToPixel_X(.Width)
  1002.             cy = CHimetricToPixel_Y(.Height)
  1003.             Brush = CreateSolidBrush(WinColor(BackColor))
  1004.             hDCScreen = GetDC(0)
  1005.             If hDCScreen <> 0 Then
  1006.                 hDC = CreateCompatibleDC(hDCScreen)
  1007.                 If hDC <> 0 Then
  1008.                     hBmp = CreateCompatibleBitmap(hDCScreen, cx, cy)
  1009.                     If hBmp <> 0 Then
  1010.                         hBmpOld = SelectObject(hDC, hBmp)
  1011.                         If .Type = vbPicTypeIcon Then
  1012.                             Const DI_NORMAL As Long = &H3
  1013.                             DrawIconEx hDC, 0, 0, .Handle, cx, cy, 0, Brush, DI_NORMAL
  1014.                         Else
  1015.                             Dim RC As RECT
  1016.                             RC.Right = cx
  1017.                             RC.Bottom = cy
  1018.                             FillRect hDC, RC, Brush
  1019.                             .Render hDC Or 0&, 0&, 0&, cx Or 0&, cy Or 0&, 0&, .Height, .Width, -.Height, ByVal 0&
  1020.                         End If
  1021.                         SelectObject hDC, hBmpOld
  1022.                         BitmapHandleFromPicture = hBmp
  1023.                     End If
  1024.                     DeleteDC hDC
  1025.                 End If
  1026.                 ReleaseDC 0, hDCScreen
  1027.             End If
  1028.             DeleteObject Brush
  1029.         End If
  1030.     End With
  1031. End Function

  1032. 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)
  1033.     ' RenderFlag is passed as a optional parameter ByRef.
  1034.     ' It is ignored for icons and metafiles.
  1035.     ' 0 = render method unknown, determine it and update parameter
  1036.     ' 1 = StdPicture.Render
  1037.     ' 2 = GdiAlphaBlend
  1038.     If Picture Is Nothing Then Exit Sub
  1039.     With Picture
  1040.         If .Handle <> 0 Then
  1041.             If cx = 0 Then cx = CHimetricToPixel_X(.Width)
  1042.             If cy = 0 Then cy = CHimetricToPixel_Y(.Height)
  1043.             If .Type = vbPicTypeIcon Then
  1044.                 Const DI_NORMAL As Long = &H3
  1045.                 DrawIconEx hDC, X, Y, .Handle, cx, cy, 0, 0, DI_NORMAL
  1046.             Else
  1047.                 Dim HasAlpha As Boolean
  1048.                 If .Type = vbPicTypeBitmap Then
  1049.                     If RenderFlag = 0 Then
  1050.                         Const PICTURE_TRANSPARENT As Long = &H2
  1051.                         If (.Attributes And PICTURE_TRANSPARENT) = 0 Then       ' Exclude GIF
  1052.                             Dim Bmp As BITMAP
  1053.                             GetObjectAPI .Handle, LenB(Bmp), Bmp
  1054.                             If Bmp.BMBitsPixel = 32 And Bmp.BMBits <> 0 Then
  1055.                                 Dim SA1D As SAFEARRAY1D, b() As Byte
  1056.                                 With SA1D
  1057.                                     .cDims = 1
  1058.                                     .fFeatures = 0
  1059.                                     .cbElements = 1
  1060.                                     .cLocks = 0
  1061.                                     .pvData = Bmp.BMBits
  1062.                                     .Bounds.lLbound = 0
  1063.                                     .Bounds.cElements = Bmp.BMWidthBytes * Bmp.BMHeight
  1064.                                 End With
  1065.                                 CopyMemory ByVal ArrPtr(b()), VarPtr(SA1D), 4
  1066.                                 Dim i As Long, j As Long, Pos As Long
  1067.                                 For i = 0 To (Abs(Bmp.BMHeight) - 1)
  1068.                                     Pos = i * Bmp.BMWidthBytes
  1069.                                     For j = (Pos + 3) To (Pos + Bmp.BMWidthBytes - 1) Step 4
  1070.                                         If HasAlpha = False Then HasAlpha = (b(j) > 0)
  1071.                                         If HasAlpha = True Then
  1072.                                             If b(j - 1) > b(j) Then
  1073.                                                 HasAlpha = False
  1074.                                                 i = Abs(Bmp.BMHeight) - 1
  1075.                                                 Exit For
  1076.                                             ElseIf b(j - 2) > b(j) Then
  1077.                                                 HasAlpha = False
  1078.                                                 i = Abs(Bmp.BMHeight) - 1
  1079.                                                 Exit For
  1080.                                             ElseIf b(j - 3) > b(j) Then
  1081.                                                 HasAlpha = False
  1082.                                                 i = Abs(Bmp.BMHeight) - 1
  1083.                                                 Exit For
  1084.                                             End If
  1085.                                         End If
  1086.                                     Next j
  1087.                                 Next i
  1088.                                 CopyMemory ByVal ArrPtr(b()), 0&, 4
  1089.                             End If
  1090.                         End If
  1091.                         If HasAlpha = False Then RenderFlag = 1 Else RenderFlag = 2
  1092.                     ElseIf RenderFlag = 2 Then
  1093.                         HasAlpha = True
  1094.                     End If
  1095.                 End If
  1096.                 If HasAlpha = False Then
  1097.                     .Render hDC Or 0&, X Or 0&, Y Or 0&, cx Or 0&, cy Or 0&, 0&, .Height, .Width, -.Height, ByVal 0&
  1098.                 Else
  1099.                     Dim hDCBmp As Long, hBmpOld As Long
  1100.                     hDCBmp = CreateCompatibleDC(0)
  1101.                     If hDCBmp <> 0 Then
  1102.                         hBmpOld = SelectObject(hDCBmp, .Handle)
  1103.                         GdiAlphaBlend hDC, X, Y, cx, cy, hDCBmp, 0, 0, CHimetricToPixel_X(.Width), CHimetricToPixel_Y(.Height), &H1FF0000
  1104.                         SelectObject hDCBmp, hBmpOld
  1105.                         DeleteDC hDCBmp
  1106.                     End If
  1107.                 End If
  1108.             End If
  1109.         End If
  1110.     End With
  1111. End Sub
复制代码
GoogleTranslate.bas
  1. 'Google Translate 模块
  2. '需添加cStringBuilder.cls 和 JSON.cls两个类模块

  3. '原作者:巴西_prince
  4. '原网站链接:https://cloud.tencent.com/developer/article/1496152
  5. '原发布时间:2019-08-28

  6. '修改者:马云爱逛京东
  7. '修改时间:2019-10-27
  8. '修改内容:整理了翻译的一些函数/子过程,新增翻译函数Translate

  9. Option Explicit

  10. Public JSO As New JSON

  11. Public Enum tLang
  12.     ChineseSimplified = 0 'zh-CN
  13.     English = 1 'en
  14.     ChineseTraditional = 2 'zh-TW
  15.     Russian = 3 'ru
  16.     German = 4
  17.     French = 5
  18.     Japanese = 6
  19.     Korean = 7
  20. End Enum


  21. ''翻译
  22. Public Function Translate(ByVal Text As String, Optional ByVal Language As tLang = ChineseSimplified) As String
  23.     On Error GoTo Err01
  24.     Dim CenterData As String, strOut As String
  25.     CenterData = GetData(GOOGLEURL(Text, Language))
  26.     Dim j As Object, i As Integer
  27.     Set j = JSO.parse(CenterData)
  28.     For i = 1 To j(1)(1).Count
  29.         strOut = strOut & j(1)(i)(1)
  30.     Next
  31.     Translate = strOut
  32.     Exit Function
  33.    
  34. Err01:
  35. Translate = strOut
  36. Debug.Print "发生了某些错误。"
  37.     Exit Function
  38. End Function

  39. ''地址拼接
  40. Public Function GOOGLEURL(ByVal Text As String, ByVal Lang As tLang) As String
  41.     Dim TKK As String
  42.     TKK = Split(get_regdata(GetData("https://translate.google.cn"), "tkk:.*?,")(0), "'")(1)
  43.     Dim U As String, data As String, TL As String
  44.     Select Case Lang
  45.         Case ChineseSimplified
  46.             TL = "zh-CN"
  47.                 Case English
  48.             TL = "en"
  49.         Case ChineseTraditional
  50.             TL = "zh-TW"
  51.         Case Russian
  52.             TL = "ru"
  53.         Case German
  54.             TL = "de"
  55. Case French
  56.             TL = "fr"
  57.           Case Japanese
  58.             TL = "ja"
  59.             Case Korean
  60.             TL = "ko"
  61.     End Select
  62.     data = Replace(Text, vbCrLf, "\r\n")
  63.     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&" & _
  64.         "dt=qca&dt=rw&dt=rm&dt=ss&dt=t&dt=gt&source=bh&ssel=0&tsel=0&kc=1&tk=" & TK(data, TKK) & _
  65.         "&q=" & URLEncodeGbk(data)
  66.     GOOGLEURL = U
  67. End Function

  68. ''地址转换
  69. Public Function URLEncodeGbk(nStr As String) As String
  70.     Dim js As Object
  71.     Set js = CreateObject("ScriptControl")
  72.     js.Language = "JScript"
  73.     js.addcode ("function b(a) {return encodeURIComponent(a)}")
  74.     URLEncodeGbk = js.eval("b('" & nStr & "')")
  75. End Function

  76. ''计算TK
  77. Public Function TK(t As String, TKK As String) As String
  78.     Dim js As Object
  79.     Set js = CreateObject("ScriptControl")
  80.     js.Language = "JScript"
  81.     js.addcode ("function b(a, b) {for (var d = 0; d < b.length - 2; d += 3) {var c = b.charAt(d + 2)," & _
  82.         "c = 'a' <= c ? c.charCodeAt(0) - 87 : Number(c),c = '+' == b.charAt(d + 1) ? a >>> c : a " & _
  83.         "<< c,a = '+' == b.charAt(d) ? a + c & 4294967295 : a ^ c}return a};function tk(a, TKK) {for " & _
  84.         "(var e = TKK.split('.'), h = Number(e[0]) || 0, g = [], d = 0, f = 0; f < a.length; f++) {var c =" & _
  85.         " a.charCodeAt(f);128 > c ?g[d++] = c : (2048 > c ?g[d++] = c >> 6 | 192 : (55296 == (c & 64512) && " & _
  86.         "f + 1 < a.length && 56320 == (a.charCodeAt(f + 1) & 64512) ?(c = 65536 + ((c & 1023) << 10) +" & _
  87.         " (a.charCodeAt(++f) & 1023), g[d++] = c >> 18 | 240, g[d++] = c >> 12 & 63 | 128) : g[d++] = c >> " & _
  88.         "12 | 224, g[d++] = c >> 6 & 63 | 128), g[d++] = c & 63 | 128)}a = h;for (d = 0; d < g.length; d++)a " & _
  89.         "+= g[d], a = b(a, '+-a^+6');a = b(a, '+-3^+b+-f');a ^= Number(e[1]) || 0;0 > a && (a = (a & 2147483647) " & _
  90.         "+ 2147483648);a %= 1E6;return a.toString() + '.' + (a ^ h)}")
  91.     TK = js.eval("tk('" & t & "','" & TKK & "')")
  92. End Function

  93. ''正则表达式函数
  94. Public Function get_regdata(ByVal str As Variant, ByVal rexData As String) As Variant
  95.     Dim mRegExp As Object
  96.     Dim mMatches As Object
  97.     Dim mMatch As Object
  98.     Dim arr() As Variant
  99.     Set mRegExp = CreateObject("Vbscript.Regexp")
  100.     With mRegExp
  101.         .Global = True
  102.         .IgnoreCase = True
  103.         .Pattern = rexData
  104.         Set mMatches = .Execute(str)
  105.         ReDim arr(mMatches.Count)
  106.         Dim i As Integer
  107.         i = 0
  108.         For Each mMatch In mMatches
  109.             arr(i) = mMatch.Value
  110.             i = i + 1
  111.         Next
  112.     End With
  113.     get_regdata = arr
  114.     Set mRegExp = Nothing
  115.     Set mMatches = Nothing
  116. End Function

  117. ''GET数据
  118. Public Function GetData(ByVal url As String) As Variant
  119.     On Error GoTo ERR:
  120.     Dim XMLHTTP As Object
  121.     Dim zflx As String
  122.     Dim bty() As Byte
  123.     Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
  124.     XMLHTTP.Open "get", url, True
  125. '    XMLHTTP.setrequestheader "Content-Type", "application/x-www-form-urlencoded"
  126. '    XMLHTTP.setrequestheader "User-Agent", "Mozilla/5.0 (Windows NT 10; Win64; x64; rv:66.0) Gecko/20191027 Firefox/70.0"
  127.     XMLHTTP.send
  128.     While XMLHTTP.ReadyState <> 4
  129.         DoEvents
  130.     Wend
  131.     zflx = XMLHTTP.ResponseText
  132.     GetData = zflx
  133.     Set XMLHTTP = Nothing
  134.     Exit Function
  135. ERR:
  136.     GetData = ""
  137. End Function
复制代码
iniReadWrite.bas

  1. 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
  2. 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
  3. 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

  4. '读取
  5. Public Function ReadIniKeyValue(ByRef IniFileName As String, ByVal Section As String, ByVal key As String, Optional ByVal DefaultValue As String = vbNullString) As String
  6.     Dim stemp As String * 256
  7.     Dim nlen As Integer
  8.     stemp = Space$(256)
  9.     nlen = GetPrivateProfileString(Section, key, DefaultValue, stemp, 255, App.Path & "\" & IniFileName)
  10.     ReadIniKeyValue = Left$(stemp, nlen)
  11. End Function

  12. '写入
  13. Public Sub WriteIniKeyValue(ByRef IniFileName As String, ByVal Section As String, ByVal key As String, ByVal Value As String)
  14.     Dim buff As String * 256, i As Integer
  15.     buff = Value + Chr(0)
  16.     WritePrivateProfileString Section, key, buff, App.Path & "\" & IniFileName
  17. End Sub
复制代码
VisualStyles.bas
  1. Option Explicit
  2. 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
  3. Public Declare Function RemoveVisualStyles Lib "uxtheme" Alias "SetWindowTheme" (ByVal hwnd As Long, Optional ByRef pszSubAppName As String = " ", Optional ByRef pszSubIdList As String = " ") As Long
  4. Public Declare Function GetVisualStyles Lib "uxtheme" Alias "GetWindowTheme" (ByVal hwnd As Long) As Long
  5. Private Type TINITCOMMONCONTROLSEX
  6.     dwSize As Long
  7.     dwICC As Long
  8. End Type
  9. Private Type TRELEASE
  10.     IUnk As IUnknown
  11.     VTable(0 To 2) As Long
  12.     VTableHeaderPointer As Long
  13. End Type
  14. Private Type TRACKMOUSEEVENTSTRUCT
  15.     cbSize As Long
  16.     dwFlags As Long
  17.     hWndTrack As Long
  18.     dwHoverTime As Long
  19. End Type
  20. Private Enum UxThemeButtonParts
  21.     BP_PUSHBUTTON = 1
  22.     BP_RADIOBUTTON = 2
  23.     BP_CHECKBOX = 3
  24.     BP_GROUPBOX = 4
  25.     BP_USERBUTTON = 5
  26. End Enum
  27. Private Enum UxThemeButtonStates
  28.     PBS_NORMAL = 1
  29.     PBS_HOT = 2
  30.     PBS_PRESSED = 3
  31.     PBS_DISABLED = 4
  32.     PBS_DEFAULTED = 5
  33. End Enum
  34. Private Type POINTAPI
  35.     X As Long
  36.     Y As Long
  37. End Type
  38. Private Type RECT
  39.     Left As Long
  40.     Top As Long
  41.     Right As Long
  42.     Bottom As Long
  43. End Type
  44. Private Type PAINTSTRUCT
  45.     hDC As Long
  46.     fErase As Long
  47.     RCPaint As RECT
  48.     fRestore As Long
  49.     fIncUpdate As Long
  50.     RGBReserved(0 To 31) As Byte
  51. End Type
  52. Private Type DLLVERSIONINFO
  53.     cbSize As Long
  54.     dwMajor As Long
  55.     dwMinor As Long
  56.     dwBuildNumber As Long
  57.     dwPlatformID As Long
  58. End Type
  59. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
  60. Private Declare Function InitCommonControlsEx Lib "comctl32" (ByRef ICCEX As TINITCOMMONCONTROLSEX) As Long
  61. Private Declare Function SetErrorMode Lib "kernel32" (ByVal wMode As Long) As Long
  62. Private Declare Function DllGetVersion Lib "comctl32" (ByRef pdvi As DLLVERSIONINFO) As Long
  63. Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
  64. Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
  65. Private Declare Function GetFocus Lib "user32" () As Long
  66. Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As Long
  67. Private Declare Function WindowFromPoint Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
  68. Private Declare Function ExtSelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long, ByVal fnMode As Long) As Long
  69. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  70. 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
  71. Private Declare Function GetProp Lib "user32" Alias "GetPropW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
  72. Private Declare Function SetProp Lib "user32" Alias "SetPropW" (ByVal hwnd As Long, ByVal lpString As Long, ByVal hData As Long) As Long
  73. Private Declare Function RemoveProp Lib "user32" Alias "RemovePropW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
  74. Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
  75. Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
  76. Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
  77. Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As Any, ByVal bErase As Long) As Long
  78. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  79. Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
  80. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
  81. Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
  82. Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
  83. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  84. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  85. Private Declare Function DrawFocusRect Lib "user32" (ByVal hDC As Long, ByRef lpRect As RECT) As Long
  86. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  87. 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
  88. Private Declare Function TrackMouseEvent Lib "user32" (ByRef lpEventTrack As TRACKMOUSEEVENTSTRUCT) As Long
  89. 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
  90. Private Declare Function IsThemeBackgroundPartiallyTransparent Lib "uxtheme" (ByVal Theme As Long, iPartId As Long, iStateId As Long) As Long
  91. Private Declare Function DrawThemeParentBackground Lib "uxtheme" (ByVal hwnd As Long, ByVal hDC As Long, ByRef pRect As RECT) As Long
  92. 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
  93. 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
  94. 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
  95. 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
  96. Private Declare Function OpenThemeData Lib "uxtheme" (ByVal hwnd As Long, ByVal pszClassList As Long) As Long
  97. Private Declare Function CloseThemeData Lib "uxtheme" (ByVal Theme As Long) As Long
  98. Private Declare Function IsAppThemed Lib "uxtheme" () As Long
  99. Private Declare Function IsThemeActive Lib "uxtheme" () As Long
  100. Private Declare Function GetThemeAppProperties Lib "uxtheme" () As Long
  101. 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
  102. Private Declare Function SetWindowSubclass Lib "comctl32" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
  103. Private Declare Function RemoveWindowSubclass Lib "comctl32" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
  104. Private Declare Function DefSubclassProc Lib "comctl32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  105. 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
  106. Private Const ICC_STANDARD_CLASSES As Long = &H4000
  107. Private Const STAP_ALLOW_CONTROLS As Long = (1 * (2 ^ 1))
  108. Private Const S_OK As Long = &H0
  109. Private Const UIS_CLEAR As Long = 2
  110. Private Const UISF_HIDEFOCUS As Long = &H1
  111. Private Const UISF_HIDEACCEL As Long = &H2
  112. Private Const WM_UPDATEUISTATE As Long = &H128
  113. Private Const WM_QUERYUISTATE As Long = &H129
  114. Private Const WM_SETFOCUS As Long = &H7
  115. Private Const WM_KILLFOCUS As Long = &H8
  116. Private Const WM_ENABLE As Long = &HA
  117. Private Const WM_SETREDRAW As Long = &HB
  118. Private Const WM_PAINT As Long = &HF
  119. Private Const WM_NCPAINT As Long = &H85
  120. Private Const WM_NCDESTROY As Long = &H82
  121. Private Const BM_GETSTATE As Long = &HF2
  122. Private Const WM_MOUSEMOVE As Long = &H200
  123. Private Const WM_LBUTTONDOWN As Long = &H201
  124. Private Const WM_LBUTTONUP As Long = &H202
  125. Private Const WM_RBUTTONUP As Long = &H205
  126. Private Const WM_MOUSELEAVE As Long = &H2A3
  127. Private Const WM_PRINTCLIENT As Long = &H318
  128. Private Const WM_THEMECHANGED As Long = &H31A
  129. Private Const BST_PUSHED As Long = &H4
  130. Private Const BST_FOCUS As Long = &H8
  131. Private Const DT_CENTER As Long = &H1
  132. Private Const DT_WORDBREAK As Long = &H10
  133. Private Const DT_CALCRECT As Long = &H400
  134. Private Const DT_HIDEPREFIX As Long = &H100000
  135. Private Const TME_LEAVE As Long = 2
  136. Private Const RGN_DIFF As Long = 4
  137. Private Const RGN_COPY As Long = 5
  138. Private Const DST_ICON As Long = &H3
  139. Private Const DST_BITMAP As Long = &H4
  140. Private Const DSS_DISABLED As Long = &H20

  141. Public Sub InitVisualStyles()
  142.     If App.LogMode <> 0 Then Call InitReleaseVisualStyles(AddressOf ReleaseVisualStyles)
  143.     Dim ICCEX As TINITCOMMONCONTROLSEX
  144.     With ICCEX
  145.         .dwSize = LenB(ICCEX)
  146.         .dwICC = ICC_STANDARD_CLASSES
  147.     End With
  148.     InitCommonControlsEx ICCEX
  149. End Sub

  150. Private Sub InitReleaseVisualStyles(ByVal Address As Long)
  151.     Static Release As TRELEASE
  152.     If Release.VTableHeaderPointer <> 0 Then Exit Sub
  153.     If GetComCtlVersion >= 6 Then
  154.         Release.VTable(2) = Address
  155.         Release.VTableHeaderPointer = VarPtr(Release.VTable(0))
  156.         CopyMemory Release.IUnk, VarPtr(Release.VTableHeaderPointer), 4
  157.     End If
  158. End Sub

  159. Private Function ReleaseVisualStyles() As Long
  160.     Const SEM_NOGPFAULTERRORBOX As Long = &H2
  161.     SetErrorMode SEM_NOGPFAULTERRORBOX
  162. End Function

  163. Public Sub SetupVisualStyles(ByVal Form As VB.Form)
  164.     If GetComCtlVersion() >= 6 Then SendMessage Form.hwnd, WM_UPDATEUISTATE, MakeDWord(UIS_CLEAR, UISF_HIDEFOCUS Or UISF_HIDEACCEL), ByVal 0&
  165.     If EnabledVisualStyles() = False Then Exit Sub
  166.     Dim CurrControl As VB.Control
  167.     For Each CurrControl In Form.Controls
  168.         Select Case TypeName(CurrControl)
  169.         Case "Frame"
  170.             SetWindowSubclass CurrControl.hwnd, AddressOf RedirectFrame, ObjPtr(CurrControl), 0
  171.         Case "CommandButton", "OptionButton", "CheckBox"
  172.             If CurrControl.Style = vbButtonGraphical Then
  173.                 SetProp CurrControl.hwnd, StrPtr("VisualStyles"), GetVisualStyles(CurrControl.hwnd)
  174.                 If CurrControl.Enabled = True Then SetProp CurrControl.hwnd, StrPtr("Enabled"), 1
  175.                 SetWindowSubclass CurrControl.hwnd, AddressOf RedirectButton, ObjPtr(CurrControl), ObjPtr(CurrControl)
  176.             End If
  177.         End Select
  178.     Next CurrControl
  179. End Sub

  180. Public Function EnabledVisualStyles() As Boolean
  181.     If GetComCtlVersion() >= 6 Then
  182.         If IsThemeActive() <> 0 Then
  183.             If IsAppThemed() <> 0 Then
  184.                 EnabledVisualStyles = True
  185.             ElseIf (GetThemeAppProperties() And STAP_ALLOW_CONTROLS) <> 0 Then
  186.                 EnabledVisualStyles = True
  187.             End If
  188.         End If
  189.     End If
  190. End Function

  191. Public Function GetComCtlVersion() As Long
  192.     Static Done As Boolean, Value As Long
  193.     If Done = False Then
  194.         Dim Version As DLLVERSIONINFO
  195.         On Error Resume Next
  196.         Version.cbSize = LenB(Version)
  197.         If DllGetVersion(Version) = S_OK Then Value = Version.dwMajor
  198.         Done = True
  199.     End If
  200.     GetComCtlVersion = Value
  201. End Function

  202. 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
  203.     Select Case wMsg
  204.     Case WM_PRINTCLIENT, WM_MOUSELEAVE
  205.         RedirectFrame = DefWindowProc(hwnd, wMsg, wParam, lParam)
  206.         Exit Function
  207.     End Select
  208.     RedirectFrame = DefSubclassProc(hwnd, wMsg, wParam, lParam)
  209.     If wMsg = WM_NCDESTROY Then Call RemoveRedirectFrame(hwnd, uIdSubclass)
  210. End Function

  211. Private Sub RemoveRedirectFrame(ByVal hwnd As Long, ByVal uIdSubclass As Long)
  212.     RemoveWindowSubclass hwnd, AddressOf RedirectFrame, uIdSubclass
  213. End Sub

  214. 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
  215.     Dim SetRedraw As Boolean
  216.     Select Case wMsg
  217.     Case WM_NCPAINT
  218.         Exit Function
  219.     Case WM_PAINT
  220.         If IsWindowVisible(hwnd) <> 0 And GetProp(hwnd, StrPtr("VisualStyles")) <> 0 Then
  221.             Dim PS As PAINTSTRUCT
  222.             SetProp hwnd, StrPtr("Painted"), 1
  223.             Call DrawButton(hwnd, BeginPaint(hwnd, PS), Button)
  224.             EndPaint hwnd, PS
  225.             Exit Function
  226.         End If
  227.     Case WM_SETFOCUS, WM_ENABLE
  228.         If IsWindowVisible(hwnd) <> 0 Then
  229.             SetRedraw = True
  230.             SendMessage hwnd, WM_SETREDRAW, 0, ByVal 0&
  231.         End If
  232.     End Select
  233.     RedirectButton = DefSubclassProc(hwnd, wMsg, wParam, lParam)
  234.     If wMsg = WM_NCDESTROY Then
  235.         Call RemoveRedirectButton(hwnd, uIdSubclass)
  236.         RemoveProp hwnd, StrPtr("VisualStyles")
  237.         RemoveProp hwnd, StrPtr("Enabled")
  238.         RemoveProp hwnd, StrPtr("Hot")
  239.         RemoveProp hwnd, StrPtr("Painted")
  240.         RemoveProp hwnd, StrPtr("ButtonPart")
  241.     ElseIf IsWindow(hwnd) <> 0 Then
  242.         Select Case wMsg
  243.         Case WM_THEMECHANGED
  244.             SetProp hwnd, StrPtr("VisualStyles"), GetVisualStyles(hwnd)
  245.             Button.Refresh
  246.         Case WM_MOUSELEAVE
  247.             SetProp hwnd, StrPtr("Hot"), 0
  248.             Button.Refresh
  249.         Case WM_MOUSEMOVE
  250.             If GetProp(hwnd, StrPtr("Hot")) = 0 Then
  251.                 SetProp hwnd, StrPtr("Hot"), 1
  252.                 InvalidateRect hwnd, ByVal 0&, 0
  253.                 Dim TME As TRACKMOUSEEVENTSTRUCT
  254.                 With TME
  255.                     .cbSize = LenB(TME)
  256.                     .hWndTrack = hwnd
  257.                     .dwFlags = TME_LEAVE
  258.                 End With
  259.                 TrackMouseEvent TME
  260.             ElseIf GetProp(hwnd, StrPtr("Painted")) = 0 Then
  261.                 Button.Refresh
  262.             End If
  263.         Case WM_SETFOCUS, WM_ENABLE
  264.             If SetRedraw = True Then
  265.                 SendMessage hwnd, WM_SETREDRAW, 1, ByVal 0&
  266.                 If wMsg = WM_ENABLE Then
  267.                     SetProp hwnd, StrPtr("Enabled"), 0
  268.                     InvalidateRect hwnd, ByVal 0&, 0
  269.                 Else
  270.                     SetProp hwnd, StrPtr("Enabled"), 1
  271.                     Button.Refresh
  272.                 End If
  273.             End If
  274.         Case WM_LBUTTONDOWN, WM_LBUTTONUP, WM_RBUTTONUP
  275.             Button.Refresh
  276.         End Select
  277.     End If
  278. End Function

  279. Private Sub RemoveRedirectButton(ByVal hwnd As Long, ByVal uIdSubclass As Long)
  280.     RemoveWindowSubclass hwnd, AddressOf RedirectButton, uIdSubclass
  281. End Sub

  282. Private Sub DrawButton(ByVal hwnd As Long, ByVal hDC As Long, ByVal Button As Object)
  283.     Dim Theme As Long, ButtonPart As Long, ButtonState As Long, UIState As Long
  284.     Dim Enabled As Boolean, Checked As Boolean, Default As Boolean, Hot As Boolean, Pushed As Boolean, Focused As Boolean
  285.     Dim hFontOld As Long, ButtonFont As IFont
  286.     Dim ButtonPicture As IPictureDisp, DisabledPictureAvailable As Boolean
  287.     Dim ClientRect As RECT, TextRect As RECT, RgnClip As Long
  288.     Dim cx As Long, cy As Long, X As Long, Y As Long
  289.     ButtonPart = GetProp(hwnd, StrPtr("ButtonPart"))
  290.     If ButtonPart = 0 Then
  291.         Select Case TypeName(Button)
  292.         Case "CommandButton"
  293.             ButtonPart = BP_PUSHBUTTON
  294.         Case "OptionButton"
  295.             ButtonPart = BP_RADIOBUTTON
  296.         Case "CheckBox"
  297.             ButtonPart = BP_CHECKBOX
  298.         End Select
  299.         If ButtonPart <> 0 Then SetProp hwnd, StrPtr("ButtonPart"), ButtonPart
  300.     End If
  301.     Select Case ButtonPart
  302.     Case BP_PUSHBUTTON
  303.         Default = Button.Default
  304.         If GetFocus() <> hwnd Then
  305.             On Error Resume Next
  306.             If CLng(Button.Parent.ActiveControl.Default) > 0 Then Else Default = False
  307.             On Error GoTo 0
  308.         End If
  309.     Case BP_RADIOBUTTON
  310.         Checked = Button.Value
  311.         Default = False
  312.     Case BP_CHECKBOX
  313.         Checked = IIf(Button.Value = vbChecked, True, False)
  314.         Default = False
  315.     End Select
  316.     ButtonPart = BP_PUSHBUTTON
  317.     ButtonState = SendMessage(hwnd, BM_GETSTATE, 0, ByVal 0&)
  318.     UIState = SendMessage(hwnd, WM_QUERYUISTATE, 0, ByVal 0&)
  319.     Enabled = IIf(GetProp(hwnd, StrPtr("Enabled")) = 1, True, Button.Enabled)
  320.     Hot = IIf(GetProp(hwnd, StrPtr("Hot")) = 0, False, True)
  321.     If Checked = True Then Hot = False
  322.     Pushed = IIf((ButtonState And BST_PUSHED) = 0, False, True)
  323.     Focused = IIf((ButtonState And BST_FOCUS) = 0, False, True)
  324.     If Enabled = False Then
  325.         ButtonState = PBS_DISABLED
  326.         Set ButtonPicture = CoalescePicture(Button.DisabledPicture, Button.Picture)
  327.         If Not Button.DisabledPicture Is Nothing Then
  328.             If Button.DisabledPicture.Handle <> 0 Then DisabledPictureAvailable = True
  329.         End If
  330.     ElseIf Hot = True And Pushed = False Then
  331.         ButtonState = PBS_HOT
  332.         If Checked = True Then
  333.             Set ButtonPicture = CoalescePicture(Button.DownPicture, Button.Picture)
  334.         Else
  335.             Set ButtonPicture = Button.Picture
  336.         End If
  337.     ElseIf Checked = True Or Pushed = True Then
  338.         ButtonState = PBS_PRESSED
  339.         Set ButtonPicture = CoalescePicture(Button.DownPicture, Button.Picture)
  340.     ElseIf Focused = True Or Default = True Then
  341.         ButtonState = PBS_DEFAULTED
  342.         Set ButtonPicture = Button.Picture
  343.     Else
  344.         ButtonState = PBS_NORMAL
  345.         Set ButtonPicture = Button.Picture
  346.     End If
  347.     If Not ButtonPicture Is Nothing Then
  348.         If ButtonPicture.Handle = 0 Then Set ButtonPicture = Nothing
  349.     End If
  350.     GetClientRect hwnd, ClientRect
  351.     Theme = OpenThemeData(hwnd, StrPtr("Button"))
  352.     If Theme <> 0 Then
  353.         GetThemeBackgroundRegion Theme, hDC, ButtonPart, ButtonState, ClientRect, RgnClip
  354.         ExtSelectClipRgn hDC, RgnClip, RGN_DIFF
  355.         Dim Brush As Long
  356.         Brush = CreateSolidBrush(WinColor(Button.BackColor))
  357.         FillRect hDC, ClientRect, Brush
  358.         DeleteObject Brush
  359.         If IsThemeBackgroundPartiallyTransparent(Theme, ButtonPart, ButtonState) <> 0 Then DrawThemeParentBackground hwnd, hDC, ClientRect
  360.         ExtSelectClipRgn hDC, 0, RGN_COPY
  361.         DeleteObject RgnClip
  362.         DrawThemeBackground Theme, hDC, ButtonPart, ButtonState, ClientRect, ClientRect
  363.         GetThemeBackgroundContentRect Theme, hDC, ButtonPart, ButtonState, ClientRect, ClientRect
  364.         If Focused = True Then
  365.             If Not (UIState And UISF_HIDEFOCUS) = UISF_HIDEFOCUS Then DrawFocusRect hDC, ClientRect
  366.         End If
  367.         If Not Button.Caption = vbNullString Then
  368.             Set ButtonFont = Button.Font
  369.             hFontOld = SelectObject(hDC, ButtonFont.hFont)
  370.             LSet TextRect = ClientRect
  371.             DrawText hDC, StrPtr(Button.Caption), -1, TextRect, DT_CALCRECT Or DT_WORDBREAK Or CLng(IIf((UIState And UISF_HIDEACCEL) = UISF_HIDEACCEL, DT_HIDEPREFIX, 0))
  372.             TextRect.Left = ClientRect.Left
  373.             TextRect.Right = ClientRect.Right
  374.             If ButtonPicture Is Nothing Then
  375.                 TextRect.Top = ((ClientRect.Bottom - TextRect.Bottom) / 2) + (3 * PixelsPerDIP_Y())
  376.                 TextRect.Bottom = TextRect.Top + TextRect.Bottom
  377.             Else
  378.                 TextRect.Top = (ClientRect.Bottom - TextRect.Bottom) + (1 * PixelsPerDIP_Y())
  379.                 TextRect.Bottom = ClientRect.Bottom
  380.             End If
  381.             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
  382.             SelectObject hDC, hFontOld
  383.             ClientRect.Bottom = TextRect.Top
  384.             ClientRect.Left = TextRect.Left
  385.         End If
  386.         CloseThemeData Theme
  387.     End If
  388.     If Not ButtonPicture Is Nothing Then
  389.         cx = CHimetricToPixel_X(ButtonPicture.Width)
  390.         cy = CHimetricToPixel_Y(ButtonPicture.Height)
  391.         X = ClientRect.Left + ((ClientRect.Right - ClientRect.Left - cx) / 2)
  392.         Y = ClientRect.Top + ((ClientRect.Bottom - ClientRect.Top - cy) / 2)
  393.         If Enabled = True Or DisabledPictureAvailable = True Then
  394.             If ButtonPicture.Type = vbPicTypeBitmap And Button.UseMaskColor = True Then
  395.                 Dim hDCScreen As Long
  396.                 Dim hDC1 As Long, hBmpOld1 As Long
  397.                 hDCScreen = GetDC(0)
  398.                 If hDCScreen <> 0 Then
  399.                     hDC1 = CreateCompatibleDC(hDCScreen)
  400.                     If hDC1 <> 0 Then
  401.                         hBmpOld1 = SelectObject(hDC1, ButtonPicture.Handle)
  402.                         TransparentBlt hDC, X, Y, cx, cy, hDC1, 0, 0, cx, cy, WinColor(Button.MaskColor)
  403.                         SelectObject hDC1, hBmpOld1
  404.                         DeleteDC hDC1
  405.                     End If
  406.                     ReleaseDC 0, hDCScreen
  407.                 End If
  408.             Else
  409.                 With ButtonPicture
  410.                     .Render hDC Or 0&, X Or 0&, Y Or 0&, cx Or 0&, cy Or 0&, 0&, .Height, .Width, -.Height, ByVal 0&
  411.                 End With
  412.             End If
  413.         Else
  414.             If ButtonPicture.Type = vbPicTypeIcon Then
  415.                 DrawState hDC, 0, 0, ButtonPicture.Handle, 0, X, Y, cx, cy, DST_ICON Or DSS_DISABLED
  416.             Else
  417.                 Dim hImage As Long
  418.                 hImage = BitmapHandleFromPicture(ButtonPicture, vbWhite)
  419.                 ' The DrawState API with DSS_DISABLED will draw white as transparent.
  420.                 ' This will ensure GIF bitmaps or metafiles are better drawn.
  421.                 DrawState hDC, 0, 0, hImage, 0, X, Y, cx, cy, DST_BITMAP Or DSS_DISABLED
  422.                 DeleteObject hImage
  423.             End If
  424.         End If
  425.     End If
  426. End Sub

  427. Private Function CoalescePicture(ByVal Picture As IPictureDisp, ByVal DefaultPicture As IPictureDisp) As IPictureDisp
  428.     If Picture Is Nothing Then
  429.         Set CoalescePicture = DefaultPicture
  430.     ElseIf Picture.Handle = 0 Then
  431.         Set CoalescePicture = DefaultPicture
  432.     Else
  433.         Set CoalescePicture = Picture
  434.     End If
  435. End Function
复制代码
VTableHandle.bas
  1. Option Explicit

  2. ' Required:

  3. ' OLEGuids.tlb (in IDE only)

  4. #If False Then
  5. Private VTableInterfaceControl, VTableInterfaceInPlaceActiveObject, VTableInterfacePerPropertyBrowsing
  6. #End If
  7. Public Enum VTableInterfaceConstants
  8.     VTableInterfaceControl = 1
  9.     VTableInterfaceInPlaceActiveObject = 2
  10.     VTableInterfacePerPropertyBrowsing = 3
  11. End Enum
  12. Private Type VTableIPAODataStruct
  13.     VTable As Long
  14.     RefCount As Long
  15.     OriginalIOleIPAO As OLEGuids.IOleInPlaceActiveObject
  16.     IOleIPAO As OLEGuids.IOleInPlaceActiveObjectVB
  17. End Type
  18. Private Enum VTableIndexControlConstants
  19. ' Ignore : ControlQueryInterface = 1
  20. ' Ignore : ControlAddRef = 2
  21. ' Ignore : ControlRelease = 3
  22.     VTableIndexControlGetControlInfo = 4
  23.     VTableIndexControlOnMnemonic = 5
  24.     ' Ignore : ControlOnAmbientPropertyChange = 6
  25.     ' Ignore : ControlFreezeEvents = 7
  26. End Enum
  27. Private Enum VTableIndexPPBConstants
  28. ' Ignore : PPBQueryInterface = 1
  29. ' Ignore : PPBAddRef = 2
  30. ' Ignore : PPBRelease = 3
  31.     VTableIndexPPBGetDisplayString = 4
  32.     ' Ignore : PPBMapPropertyToPage = 5
  33.     VTAbleIndexPPBGetPredefinedStrings = 6
  34.     VTAbleIndexPPBGetPredefinedValue = 7
  35. End Enum
  36. Private Type VTableIEnumVARIANTDataStruct
  37.     VTable As Long
  38.     RefCount As Long
  39.     Enumerable As Object
  40.     Index As Long
  41.     Count As Long
  42. End Type
  43. Public Const CTRLINFO_EATS_RETURN As Long = 1
  44. Public Const CTRLINFO_EATS_ESCAPE As Long = 2
  45. Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal hMem As Long)
  46. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
  47. Private Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
  48. Private Declare Function EnumThreadWindows Lib "user32" (ByVal dwThreadID As Long, ByVal lpfn As Long, ByVal lParam As Long) As Long
  49. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  50. Private Declare Function SetProp Lib "user32" Alias "SetPropW" (ByVal hwnd As Long, ByVal lpString As Long, ByVal hData As Long) As Long
  51. Private Declare Function GetProp Lib "user32" Alias "GetPropW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
  52. Private Declare Function RemoveProp Lib "user32" Alias "RemovePropW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
  53. Private Declare Function GetAncestor Lib "user32" (ByVal hwnd As Long, ByVal gaFlags As Long) As Long
  54. Private Declare Function CoTaskMemAlloc Lib "ole32" (ByVal cBytes As Long) As Long
  55. Private Declare Function SysAllocString Lib "oleaut32" (ByVal lpString As Long) As Long
  56. 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
  57. Private Declare Function VariantCopyToPtr Lib "oleaut32" Alias "VariantCopy" (ByVal pvargDest As Long, ByRef pvargSrc As Variant) As Long
  58. Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszProgID As Long, ByRef pCLSID As Any) As Long
  59. Private Const CC_STDCALL As Long = 4
  60. Private Const GA_ROOT As Long = 2
  61. Private Const GWL_HWNDPARENT As Long = (-8)
  62. Private Const E_OUTOFMEMORY As Long = &H8007000E
  63. Private Const E_INVALIDARG As Long = &H80070057
  64. Private Const E_NOTIMPL As Long = &H80004001
  65. Private Const E_NOINTERFACE As Long = &H80004002
  66. Private Const E_POINTER As Long = &H80004003
  67. Private Const S_FALSE As Long = &H1
  68. Private Const S_OK As Long = &H0
  69. Private VTableIPAO(0 To 9) As Long, VTableIPAOData As VTableIPAODataStruct
  70. Private VTableSubclassControl As VTableSubclass
  71. Private VTableSubclassPPB As VTableSubclass, StringsOutArray() As String, CookiesOutArray() As Long
  72. Private VTableIEnumVARIANT(0 To 6) As Long

  73. Public Sub SetVTableSubclass(ByVal This As Object, ByVal OLEInterface As VTableInterfaceConstants)
  74.     Select Case OLEInterface
  75.     Case VTableInterfaceInPlaceActiveObject
  76.         If VTableSubclassSupported(This, VTableInterfaceInPlaceActiveObject) = True Then VTableIPAOData.RefCount = VTableIPAOData.RefCount + 1
  77.     Case VTableInterfaceControl
  78.         If VTableSubclassSupported(This, VTableInterfaceControl) = True Then Call ReplaceIOleControl(This)
  79.     Case VTableInterfacePerPropertyBrowsing
  80.         If VTableSubclassSupported(This, VTableInterfacePerPropertyBrowsing) = True Then Call ReplaceIPPB(This)
  81.     End Select
  82. End Sub

  83. Public Sub RemoveVTableSubclass(ByVal This As Object, ByVal OLEInterface As VTableInterfaceConstants)
  84.     Select Case OLEInterface
  85.     Case VTableInterfaceInPlaceActiveObject
  86.         If VTableSubclassSupported(This, VTableInterfaceInPlaceActiveObject) = True Then VTableIPAOData.RefCount = VTableIPAOData.RefCount - 1
  87.     Case VTableInterfaceControl
  88.         If VTableSubclassSupported(This, VTableInterfaceControl) = True Then Call RestoreIOleControl(This)
  89.     Case VTableInterfacePerPropertyBrowsing
  90.         If VTableSubclassSupported(This, VTableInterfacePerPropertyBrowsing) = True Then Call RestoreIPPB(This)
  91.     End Select
  92. End Sub

  93. Public Sub RemoveAllVTableSubclass(ByVal OLEInterface As VTableInterfaceConstants)
  94.     Select Case OLEInterface
  95.     Case VTableInterfaceInPlaceActiveObject
  96.         VTableIPAOData.RefCount = 0
  97.         If Not VTableIPAOData.OriginalIOleIPAO Is Nothing Then Call ActivateIPAO(VTableIPAOData.OriginalIOleIPAO)
  98.     Case VTableInterfaceControl
  99.         Set VTableSubclassControl = Nothing
  100.     Case VTableInterfacePerPropertyBrowsing
  101.         Set VTableSubclassPPB = Nothing
  102.     End Select
  103. End Sub

  104. Private Function VTableSubclassSupported(ByRef This As Object, ByVal OLEInterface As VTableInterfaceConstants) As Boolean
  105.     On Error GoTo CATCH_EXCEPTION
  106.     Select Case OLEInterface
  107.     Case VTableInterfaceInPlaceActiveObject
  108.         Dim ShadowIOleIPAO As OLEGuids.IOleInPlaceActiveObject
  109.         Dim ShadowIOleInPlaceActiveObjectVB As OLEGuids.IOleInPlaceActiveObjectVB
  110.         Set ShadowIOleIPAO = This
  111.         Set ShadowIOleInPlaceActiveObjectVB = This
  112.         VTableSubclassSupported = Not CBool(ShadowIOleIPAO Is Nothing Or ShadowIOleInPlaceActiveObjectVB Is Nothing)
  113.     Case VTableInterfaceControl
  114.         Dim ShadowIOleControl As OLEGuids.IOleControl
  115.         Dim ShadowIOleControlVB As OLEGuids.IOleControlVB
  116.         Set ShadowIOleControl = This
  117.         Set ShadowIOleControlVB = This
  118.         VTableSubclassSupported = Not CBool(ShadowIOleControl Is Nothing Or ShadowIOleControlVB Is Nothing)
  119.     Case VTableInterfacePerPropertyBrowsing
  120.         Dim ShadowIPPB As OLEGuids.IPerPropertyBrowsing
  121.         Dim ShadowIPerPropertyBrowsingVB As OLEGuids.IPerPropertyBrowsingVB
  122.         Set ShadowIPPB = This
  123.         Set ShadowIPerPropertyBrowsingVB = This
  124.         VTableSubclassSupported = Not CBool(ShadowIPPB Is Nothing Or ShadowIPerPropertyBrowsingVB Is Nothing)
  125.     End Select
  126. CATCH_EXCEPTION:
  127. End Function

  128. Public Function VTableCall(ByVal RetType As VbVarType, ByVal InterfacePointer As Long, ByVal Entry As Long, ParamArray ArgList() As Variant) As Variant
  129.     Debug.Assert Not (Entry < 1 Or InterfacePointer = 0)
  130.     Dim VarArgList As Variant, HResult As Long
  131.     VarArgList = ArgList
  132.     If UBound(VarArgList) > -1 Then
  133.         Dim i As Long, ArrVarType() As Integer, ArrVarPtr() As Long
  134.         ReDim ArrVarType(LBound(VarArgList) To UBound(VarArgList)) As Integer
  135.         ReDim ArrVarPtr(LBound(VarArgList) To UBound(VarArgList)) As Long
  136.         For i = LBound(VarArgList) To UBound(VarArgList)
  137.             ArrVarType(i) = VarType(VarArgList(i))
  138.             ArrVarPtr(i) = VarPtr(VarArgList(i))
  139.         Next i
  140.         HResult = DispCallFunc(InterfacePointer, (Entry - 1) * 4, CC_STDCALL, RetType, i, VarPtr(ArrVarType(0)), VarPtr(ArrVarPtr(0)), VTableCall)
  141.     Else
  142.         HResult = DispCallFunc(InterfacePointer, (Entry - 1) * 4, CC_STDCALL, RetType, 0, 0, 0, VTableCall)
  143.     End If
  144.     SetLastError HResult                                                        ' S_OK will clear the last error code, if any.
  145. End Function

  146. Public Function VTableInterfaceSupported(ByVal This As OLEGuids.IUnknownUnrestricted, ByVal IIDString As String) As Boolean
  147.     Debug.Assert Not (This Is Nothing)
  148.     Dim HResult As Long, IID As OLEGuids.OLECLSID, ObjectPointer As Long
  149.     CLSIDFromString StrPtr(IIDString), IID
  150.     HResult = This.QueryInterface(VarPtr(IID), ObjectPointer)
  151.     If ObjectPointer <> 0 Then
  152.         Dim IUnk As OLEGuids.IUnknownUnrestricted
  153.         CopyMemory IUnk, ObjectPointer, 4
  154.         IUnk.Release
  155.         CopyMemory IUnk, 0&, 4
  156.     End If
  157.     VTableInterfaceSupported = CBool(HResult = S_OK)
  158. End Function

  159. Public Sub SyncObjectRectsToContainer(ByVal This As Object)
  160.     On Error GoTo CATCH_EXCEPTION
  161.     Dim PropOleObject As OLEGuids.IOleObject
  162.     Dim PropOleInPlaceObject As OLEGuids.IOleInPlaceObject
  163.     Dim PropOleInPlaceSite As OLEGuids.IOleInPlaceSite
  164.     Dim PosRect As OLEGuids.OLERECT
  165.     Dim ClipRect As OLEGuids.OLERECT
  166.     Dim FrameInfo As OLEGuids.OLEINPLACEFRAMEINFO
  167.     Set PropOleObject = This
  168.     Set PropOleInPlaceObject = This
  169.     Set PropOleInPlaceSite = PropOleObject.GetClientSite
  170.     PropOleInPlaceSite.GetWindowContext Nothing, Nothing, VarPtr(PosRect), VarPtr(ClipRect), VarPtr(FrameInfo)
  171.     PropOleInPlaceObject.SetObjectRects VarPtr(PosRect), VarPtr(ClipRect)
  172. CATCH_EXCEPTION:
  173. End Sub

  174. Public Sub ActivateIPAO(ByVal This As Object)
  175.     On Error GoTo CATCH_EXCEPTION
  176.     Dim PropOleObject As OLEGuids.IOleObject
  177.     Dim PropOleInPlaceSite As OLEGuids.IOleInPlaceSite
  178.     Dim PropOleInPlaceFrame As OLEGuids.IOleInPlaceFrame
  179.     Dim PropOleInPlaceUIWindow As OLEGuids.IOleInPlaceUIWindow
  180.     Dim PropOleInPlaceActiveObject As OLEGuids.IOleInPlaceActiveObject
  181.     Dim PosRect As OLEGuids.OLERECT
  182.     Dim ClipRect As OLEGuids.OLERECT
  183.     Dim FrameInfo As OLEGuids.OLEINPLACEFRAMEINFO
  184.     Set PropOleObject = This
  185.     If VTableIPAOData.RefCount > 0 Then
  186.         With VTableIPAOData
  187.             .VTable = GetVTableIPAO()
  188.             Set .OriginalIOleIPAO = This
  189.             Set .IOleIPAO = This
  190.         End With
  191.         CopyMemory ByVal VarPtr(PropOleInPlaceActiveObject), VarPtr(VTableIPAOData), 4
  192.         PropOleInPlaceActiveObject.AddRef
  193.     Else
  194.         Set PropOleInPlaceActiveObject = This
  195.     End If
  196.     Set PropOleInPlaceSite = PropOleObject.GetClientSite
  197.     PropOleInPlaceSite.GetWindowContext PropOleInPlaceFrame, PropOleInPlaceUIWindow, VarPtr(PosRect), VarPtr(ClipRect), VarPtr(FrameInfo)
  198.     PropOleInPlaceFrame.SetActiveObject PropOleInPlaceActiveObject, vbNullString
  199.     If Not PropOleInPlaceUIWindow Is Nothing Then PropOleInPlaceUIWindow.SetActiveObject PropOleInPlaceActiveObject, vbNullString
  200. CATCH_EXCEPTION:
  201. End Sub

  202. Public Sub DeActivateIPAO()
  203.     On Error GoTo CATCH_EXCEPTION
  204.     If VTableIPAOData.OriginalIOleIPAO Is Nothing Then Exit Sub
  205.     Dim PropOleObject As OLEGuids.IOleObject
  206.     Dim PropOleInPlaceSite As OLEGuids.IOleInPlaceSite
  207.     Dim PropOleInPlaceFrame As OLEGuids.IOleInPlaceFrame
  208.     Dim PropOleInPlaceUIWindow As OLEGuids.IOleInPlaceUIWindow
  209.     Dim PosRect As OLEGuids.OLERECT
  210.     Dim ClipRect As OLEGuids.OLERECT
  211.     Dim FrameInfo As OLEGuids.OLEINPLACEFRAMEINFO
  212.     Set PropOleObject = VTableIPAOData.OriginalIOleIPAO
  213.     Set PropOleInPlaceSite = PropOleObject.GetClientSite
  214.     PropOleInPlaceSite.GetWindowContext PropOleInPlaceFrame, PropOleInPlaceUIWindow, VarPtr(PosRect), VarPtr(ClipRect), VarPtr(FrameInfo)
  215.     PropOleInPlaceFrame.SetActiveObject Nothing, vbNullString
  216.     If Not PropOleInPlaceUIWindow Is Nothing Then PropOleInPlaceUIWindow.SetActiveObject Nothing, vbNullString
  217. CATCH_EXCEPTION:
  218.     Set VTableIPAOData.OriginalIOleIPAO = Nothing
  219.     Set VTableIPAOData.IOleIPAO = Nothing
  220. End Sub

  221. Private Function GetVTableIPAO() As Long
  222.     If VTableIPAO(0) = 0 Then
  223.         VTableIPAO(0) = ProcPtr(AddressOf IOleIPAO_QueryInterface)
  224.         VTableIPAO(1) = ProcPtr(AddressOf IOleIPAO_AddRef)
  225.         VTableIPAO(2) = ProcPtr(AddressOf IOleIPAO_Release)
  226.         VTableIPAO(3) = ProcPtr(AddressOf IOleIPAO_GetWindow)
  227.         VTableIPAO(4) = ProcPtr(AddressOf IOleIPAO_ContextSensitiveHelp)
  228.         VTableIPAO(5) = ProcPtr(AddressOf IOleIPAO_TranslateAccelerator)
  229.         VTableIPAO(6) = ProcPtr(AddressOf IOleIPAO_OnFrameWindowActivate)
  230.         VTableIPAO(7) = ProcPtr(AddressOf IOleIPAO_OnDocWindowActivate)
  231.         VTableIPAO(8) = ProcPtr(AddressOf IOleIPAO_ResizeBorder)
  232.         VTableIPAO(9) = ProcPtr(AddressOf IOleIPAO_EnableModeless)
  233.     End If
  234.     GetVTableIPAO = VarPtr(VTableIPAO(0))
  235. End Function

  236. Private Function IOleIPAO_QueryInterface(ByRef This As VTableIPAODataStruct, ByRef IID As OLEGuids.OLECLSID, ByRef pvObj As Long) As Long
  237.     If VarPtr(pvObj) = 0 Then
  238.         IOleIPAO_QueryInterface = E_POINTER
  239.         Exit Function
  240.     End If
  241.     ' IID_IOleInPlaceActiveObject = {00000117-0000-0000-C000-000000000046}
  242.     If IID.Data1 = &H117 And IID.Data2 = &H0 And IID.Data3 = &H0 Then
  243.         If IID.Data4(0) = &HC0 And IID.Data4(1) = &H0 And IID.Data4(2) = &H0 And IID.Data4(3) = &H0 _
  244.             And IID.Data4(4) = &H0 And IID.Data4(5) = &H0 And IID.Data4(6) = &H0 And IID.Data4(7) = &H46 Then
  245.             pvObj = VarPtr(This)
  246.             IOleIPAO_AddRef This
  247.             IOleIPAO_QueryInterface = S_OK
  248.         Else
  249.             IOleIPAO_QueryInterface = This.OriginalIOleIPAO.QueryInterface(VarPtr(IID), pvObj)
  250.         End If
  251.     Else
  252.         IOleIPAO_QueryInterface = This.OriginalIOleIPAO.QueryInterface(VarPtr(IID), pvObj)
  253.     End If
  254. End Function

  255. Private Function IOleIPAO_AddRef(ByRef This As VTableIPAODataStruct) As Long
  256.     IOleIPAO_AddRef = This.OriginalIOleIPAO.AddRef
  257. End Function

  258. Private Function IOleIPAO_Release(ByRef This As VTableIPAODataStruct) As Long
  259.     IOleIPAO_Release = This.OriginalIOleIPAO.Release
  260. End Function

  261. Private Function IOleIPAO_GetWindow(ByRef This As VTableIPAODataStruct, ByRef hwnd As Long) As Long
  262.     IOleIPAO_GetWindow = This.OriginalIOleIPAO.GetWindow(hwnd)
  263. End Function

  264. Private Function IOleIPAO_ContextSensitiveHelp(ByRef This As VTableIPAODataStruct, ByVal EnterMode As Long) As Long
  265.     IOleIPAO_ContextSensitiveHelp = This.OriginalIOleIPAO.ContextSensitiveHelp(EnterMode)
  266. End Function

  267. Private Function IOleIPAO_TranslateAccelerator(ByRef This As VTableIPAODataStruct, ByRef Msg As OLEGuids.OLEACCELMSG) As Long
  268.     If VarPtr(Msg) = 0 Then
  269.         IOleIPAO_TranslateAccelerator = E_INVALIDARG
  270.         Exit Function
  271.     End If
  272.     On Error GoTo CATCH_EXCEPTION
  273.     Dim Handled As Boolean
  274.     IOleIPAO_TranslateAccelerator = S_OK
  275.     This.IOleIPAO.TranslateAccelerator Handled, IOleIPAO_TranslateAccelerator, Msg.Message, Msg.wParam, Msg.lParam, GetShiftStateFromMsg()
  276.     If Handled = False Then IOleIPAO_TranslateAccelerator = This.OriginalIOleIPAO.TranslateAccelerator(VarPtr(Msg))
  277.     Exit Function
  278. CATCH_EXCEPTION:
  279.     IOleIPAO_TranslateAccelerator = This.OriginalIOleIPAO.TranslateAccelerator(VarPtr(Msg))
  280. End Function

  281. Private Function IOleIPAO_OnFrameWindowActivate(ByRef This As VTableIPAODataStruct, ByVal Activate As Long) As Long
  282.     IOleIPAO_OnFrameWindowActivate = This.OriginalIOleIPAO.OnFrameWindowActivate(Activate)
  283. End Function

  284. Private Function IOleIPAO_OnDocWindowActivate(ByRef This As VTableIPAODataStruct, ByVal Activate As Long) As Long
  285.     IOleIPAO_OnDocWindowActivate = This.OriginalIOleIPAO.OnDocWindowActivate(Activate)
  286. End Function

  287. Private Function IOleIPAO_ResizeBorder(ByRef This As VTableIPAODataStruct, ByRef RC As OLEGuids.OLERECT, ByVal UIWindow As OLEGuids.IOleInPlaceUIWindow, ByVal FrameWindow As Long) As Long
  288.     IOleIPAO_ResizeBorder = This.OriginalIOleIPAO.ResizeBorder(VarPtr(RC), UIWindow, FrameWindow)
  289. End Function

  290. Private Function IOleIPAO_EnableModeless(ByRef This As VTableIPAODataStruct, ByVal Enable As Long) As Long
  291.     IOleIPAO_EnableModeless = This.OriginalIOleIPAO.EnableModeless(Enable)
  292. End Function

  293. Private Sub ReplaceIOleControl(ByVal This As OLEGuids.IOleControl)
  294.     If VTableSubclassControl Is Nothing Then Set VTableSubclassControl = New VTableSubclass
  295.     If VTableSubclassControl.RefCount = 0 Then
  296.         Dim hMain As Long, Handled As Boolean
  297.         hMain = GetHiddenMainWindow()
  298.         If hMain <> 0 Then Handled = CBool(GetProp(hMain, StrPtr("VTableSubclassControlInit")) <> 0)
  299.         If Handled = False Then
  300.             VTableSubclassControl.Subclass ObjPtr(This), VTableIndexControlGetControlInfo, VTableIndexControlOnMnemonic, _
  301.             AddressOf IOleControl_GetControlInfo, _
  302.             AddressOf IOleControl_OnMnemonic
  303.             If hMain <> 0 Then SetProp hMain, StrPtr("VTableSubclassControlInit"), 1
  304.         End If
  305.     End If
  306.     VTableSubclassControl.AddRef
  307. End Sub

  308. Private Sub RestoreIOleControl(ByVal This As OLEGuids.IOleControl)
  309.     If Not VTableSubclassControl Is Nothing Then
  310.         VTableSubclassControl.Release
  311.         If VTableSubclassControl.RefCount = 0 Then
  312.             Dim hMain As Long
  313.             hMain = GetHiddenMainWindow()
  314.             If hMain <> 0 Then RemoveProp hMain, StrPtr("VTableSubclassControlInit")
  315.             VTableSubclassControl.UnSubclass
  316.         End If
  317.     End If
  318. End Sub

  319. Public Sub OnControlInfoChanged(ByVal This As Object, Optional ByVal OnFocus As Boolean)
  320.     On Error GoTo CATCH_EXCEPTION
  321.     Dim PropOleObject As OLEGuids.IOleObject
  322.     Dim PropOleControlSite As OLEGuids.IOleControlSite
  323.     Set PropOleObject = This
  324.     Set PropOleControlSite = PropOleObject.GetClientSite
  325.     PropOleControlSite.OnControlInfoChanged
  326.     If OnFocus = True Then PropOleControlSite.OnFocus 1
  327. CATCH_EXCEPTION:
  328. End Sub

  329. Private Function IOleControl_GetControlInfo(ByVal This As Object, ByRef CI As OLEGuids.OLECONTROLINFO) As Long
  330.     If VarPtr(CI) = 0 Then
  331.         IOleControl_GetControlInfo = E_POINTER
  332.         Exit Function
  333.     End If
  334.     On Error GoTo CATCH_EXCEPTION
  335.     Dim ShadowIOleControlVB As OLEGuids.IOleControlVB, Handled As Boolean
  336.     Set ShadowIOleControlVB = This
  337.     CI.cb = LenB(CI)
  338.     ShadowIOleControlVB.GetControlInfo Handled, CI.cAccel, CI.hAccel, CI.dwFlags
  339.     If Handled = False Then
  340.         IOleControl_GetControlInfo = Original_IOleControl_GetControlInfo(This, CI)
  341.     Else
  342.         If CI.cAccel > 0 And CI.hAccel = 0 Then
  343.             IOleControl_GetControlInfo = E_OUTOFMEMORY
  344.         Else
  345.             IOleControl_GetControlInfo = S_OK
  346.         End If
  347.     End If
  348.     Exit Function
  349. CATCH_EXCEPTION:
  350.     IOleControl_GetControlInfo = Original_IOleControl_GetControlInfo(This, CI)
  351. End Function

  352. Private Function IOleControl_OnMnemonic(ByVal This As Object, ByRef Msg As OLEGuids.OLEACCELMSG) As Long
  353.     If VarPtr(Msg) = 0 Then
  354.         IOleControl_OnMnemonic = E_INVALIDARG
  355.         Exit Function
  356.     End If
  357.     On Error GoTo CATCH_EXCEPTION
  358.     Dim ShadowIOleControlVB As OLEGuids.IOleControlVB, Handled As Boolean
  359.     Set ShadowIOleControlVB = This
  360.     ShadowIOleControlVB.OnMnemonic Handled, Msg.Message, Msg.wParam, Msg.lParam, GetShiftStateFromMsg()
  361.     If Handled = False Then
  362.         IOleControl_OnMnemonic = Original_IOleControl_OnMnemonic(This, Msg)
  363.     Else
  364.         IOleControl_OnMnemonic = S_OK
  365.     End If
  366.     Exit Function
  367. CATCH_EXCEPTION:
  368.     IOleControl_OnMnemonic = Original_IOleControl_OnMnemonic(This, Msg)
  369. End Function

  370. Private Function Original_IOleControl_GetControlInfo(ByVal This As OLEGuids.IOleControl, ByRef CI As OLEGuids.OLECONTROLINFO) As Long
  371.     VTableSubclassControl.SubclassEntry(VTableIndexControlGetControlInfo) = False
  372.     Original_IOleControl_GetControlInfo = This.GetControlInfo(CI)
  373.     VTableSubclassControl.SubclassEntry(VTableIndexControlGetControlInfo) = True
  374. End Function

  375. Private Function Original_IOleControl_OnMnemonic(ByVal This As OLEGuids.IOleControl, ByRef Msg As OLEGuids.OLEACCELMSG) As Long
  376.     VTableSubclassControl.SubclassEntry(VTableIndexControlOnMnemonic) = False
  377.     Original_IOleControl_OnMnemonic = This.OnMnemonic(Msg)
  378.     VTableSubclassControl.SubclassEntry(VTableIndexControlOnMnemonic) = True
  379. End Function

  380. Private Sub ReplaceIPPB(ByVal This As OLEGuids.IPerPropertyBrowsing)
  381.     If VTableSubclassPPB Is Nothing Then Set VTableSubclassPPB = New VTableSubclass
  382.     If VTableSubclassPPB.RefCount = 0 Then
  383.         Dim hMain As Long, Handled As Boolean
  384.         hMain = GetHiddenMainWindow()
  385.         If hMain <> 0 Then Handled = CBool(GetProp(hMain, StrPtr("VTableSubclassPPBInit")) <> 0)
  386.         If Handled = False Then
  387.             VTableSubclassPPB.Subclass ObjPtr(This), VTableIndexPPBGetDisplayString, VTAbleIndexPPBGetPredefinedValue, _
  388.             AddressOf IPPB_GetDisplayString, 0, _
  389.             AddressOf IPPB_GetPredefinedStrings, _
  390.             AddressOf IPPB_GetPredefinedValue
  391.             If hMain <> 0 Then SetProp hMain, StrPtr("VTableSubclassPPBInit"), 1
  392.         End If
  393.     End If
  394.     VTableSubclassPPB.AddRef
  395. End Sub

  396. Private Sub RestoreIPPB(ByVal This As OLEGuids.IPerPropertyBrowsing)
  397.     If Not VTableSubclassPPB Is Nothing Then
  398.         VTableSubclassPPB.Release
  399.         If VTableSubclassPPB.RefCount = 0 Then
  400.             Dim hMain As Long
  401.             hMain = GetHiddenMainWindow()
  402.             If hMain <> 0 Then RemoveProp hMain, StrPtr("VTableSubclassPPBInit")
  403.             VTableSubclassPPB.UnSubclass
  404.         End If
  405.     End If
  406. End Sub

  407. Public Function GetDispID(ByVal This As Object, ByRef MethodName As String) As Long
  408.     Dim IDispatch As OLEGuids.IDispatch, IID_NULL As OLEGuids.OLECLSID
  409.     Set IDispatch = This
  410.     IDispatch.GetIDsOfNames IID_NULL, MethodName, 1, 0, GetDispID
  411. End Function

  412. Private Function IPPB_GetDisplayString(ByVal This As Object, ByVal DispID As Long, ByVal lpDisplayName As Long) As Long
  413.     If lpDisplayName = 0 Then
  414.         IPPB_GetDisplayString = E_POINTER
  415.         Exit Function
  416.     End If
  417.     On Error GoTo CATCH_EXCEPTION
  418.     Dim ShadowIPerPropertyBrowsingVB As OLEGuids.IPerPropertyBrowsingVB, Handled As Boolean, DisplayName As String
  419.     Set ShadowIPerPropertyBrowsingVB = This
  420.     ShadowIPerPropertyBrowsingVB.GetDisplayString Handled, DispID, DisplayName
  421.     If Handled = False Then
  422.         IPPB_GetDisplayString = E_NOTIMPL
  423.     Else
  424.         Dim lpString As Long
  425.         lpString = SysAllocString(StrPtr(DisplayName))
  426.         CopyMemory ByVal lpDisplayName, lpString, 4
  427.     End If
  428.     Exit Function
  429. CATCH_EXCEPTION:
  430.     IPPB_GetDisplayString = E_NOTIMPL
  431. End Function

  432. Private Function IPPB_GetPredefinedStrings(ByVal This As Object, ByVal DispID As Long, ByRef pCaStringsOut As OLEGuids.OLECALPOLESTR, ByRef pCaCookiesOut As OLEGuids.OLECADWORD) As Long
  433.     If VarPtr(pCaStringsOut) = 0 Or VarPtr(pCaCookiesOut) = 0 Then
  434.         IPPB_GetPredefinedStrings = E_POINTER
  435.         Exit Function
  436.     End If
  437.     On Error GoTo CATCH_EXCEPTION
  438.     Dim ShadowIPerPropertyBrowsingVB As OLEGuids.IPerPropertyBrowsingVB, Handled As Boolean
  439.     ReDim StringsOutArray(0) As String
  440.     ReDim CookiesOutArray(0) As Long
  441.     Set ShadowIPerPropertyBrowsingVB = This
  442.     ShadowIPerPropertyBrowsingVB.GetPredefinedStrings Handled, DispID, StringsOutArray(), CookiesOutArray()
  443.     If Handled = False Or UBound(StringsOutArray()) = 0 Then
  444.         IPPB_GetPredefinedStrings = E_NOTIMPL
  445.     Else
  446.         Dim cElems As Long, pElems As Long, nElemCount As Long
  447.         Dim lpString As Long
  448.         cElems = UBound(StringsOutArray())
  449.         If Not UBound(CookiesOutArray()) = cElems Then ReDim Preserve CookiesOutArray(cElems) As Long
  450.         pElems = CoTaskMemAlloc(cElems * 4)
  451.         pCaStringsOut.cElems = cElems
  452.         pCaStringsOut.pElems = pElems
  453.         For nElemCount = 0 To cElems - 1
  454.             lpString = CoTaskMemAlloc(Len(StringsOutArray(nElemCount)) + 1)
  455.             CopyMemory ByVal lpString, StrPtr(StringsOutArray(nElemCount)), 4
  456.             CopyMemory ByVal UnsignedAdd(pElems, nElemCount * 4), ByVal lpString, 4
  457.         Next nElemCount
  458.         pElems = CoTaskMemAlloc(cElems * 4)
  459.         pCaCookiesOut.cElems = cElems
  460.         pCaCookiesOut.pElems = pElems
  461.         For nElemCount = 0 To cElems - 1
  462.             CopyMemory ByVal UnsignedAdd(pElems, nElemCount * 4), CookiesOutArray(nElemCount), 4
  463.         Next nElemCount
  464.     End If
  465.     Exit Function
  466. CATCH_EXCEPTION:
  467.     IPPB_GetPredefinedStrings = E_NOTIMPL
  468. End Function

  469. Private Function IPPB_GetPredefinedValue(ByVal This As Object, ByVal DispID As Long, ByVal dwCookie As Long, ByRef pVarOut As Variant) As Long
  470.     If VarPtr(pVarOut) = 0 Then
  471.         IPPB_GetPredefinedValue = E_POINTER
  472.         Exit Function
  473.     End If
  474.     On Error GoTo CATCH_EXCEPTION
  475.     Dim ShadowIPerPropertyBrowsingVB As OLEGuids.IPerPropertyBrowsingVB, Handled As Boolean
  476.     Set ShadowIPerPropertyBrowsingVB = This
  477.     ShadowIPerPropertyBrowsingVB.GetPredefinedValue Handled, DispID, dwCookie, pVarOut
  478.     If Handled = False Then IPPB_GetPredefinedValue = E_NOTIMPL
  479.     Exit Function
  480. CATCH_EXCEPTION:
  481.     IPPB_GetPredefinedValue = E_NOTIMPL
  482. End Function

  483. Public Function GetNewEnum(ByVal This As Object, ByVal Upper As Long, ByVal Lower As Long) As IEnumVARIANT
  484.     Dim VTableIEnumVARIANTData As VTableIEnumVARIANTDataStruct
  485.     With VTableIEnumVARIANTData
  486.         .VTable = GetVTableIEnumVARIANT()
  487.         .RefCount = 1
  488.         Set .Enumerable = This
  489.         .Index = Lower
  490.         .Count = Upper
  491.         Dim hMem As Long
  492.         hMem = CoTaskMemAlloc(LenB(VTableIEnumVARIANTData))
  493.         If hMem <> 0 Then
  494.             CopyMemory ByVal hMem, VTableIEnumVARIANTData, LenB(VTableIEnumVARIANTData)
  495.             CopyMemory ByVal VarPtr(GetNewEnum), hMem, 4
  496.             CopyMemory ByVal VarPtr(.Enumerable), 0&, 4
  497.         End If
  498.     End With
  499. End Function

  500. Private Function GetVTableIEnumVARIANT() As Long
  501.     If VTableIEnumVARIANT(0) = 0 Then
  502.         VTableIEnumVARIANT(0) = ProcPtr(AddressOf IEnumVARIANT_QueryInterface)
  503.         VTableIEnumVARIANT(1) = ProcPtr(AddressOf IEnumVARIANT_AddRef)
  504.         VTableIEnumVARIANT(2) = ProcPtr(AddressOf IEnumVARIANT_Release)
  505.         VTableIEnumVARIANT(3) = ProcPtr(AddressOf IEnumVARIANT_Next)
  506.         VTableIEnumVARIANT(4) = ProcPtr(AddressOf IEnumVARIANT_Skip)
  507.         VTableIEnumVARIANT(5) = ProcPtr(AddressOf IEnumVARIANT_Reset)
  508.         VTableIEnumVARIANT(6) = ProcPtr(AddressOf IEnumVARIANT_Clone)
  509.     End If
  510.     GetVTableIEnumVARIANT = VarPtr(VTableIEnumVARIANT(0))
  511. End Function

  512. Private Function IEnumVARIANT_QueryInterface(ByRef This As VTableIEnumVARIANTDataStruct, ByRef IID As OLEGuids.OLECLSID, ByRef pvObj As Long) As Long
  513.     If VarPtr(pvObj) = 0 Then
  514.         IEnumVARIANT_QueryInterface = E_POINTER
  515.         Exit Function
  516.     End If
  517.     ' IID_IEnumVARIANT = {00020404-0000-0000-C000-000000000046}
  518.     If IID.Data1 = &H20404 And IID.Data2 = &H0 And IID.Data3 = &H0 Then
  519.         If IID.Data4(0) = &HC0 And IID.Data4(1) = &H0 And IID.Data4(2) = &H0 And IID.Data4(3) = &H0 _
  520.             And IID.Data4(4) = &H0 And IID.Data4(5) = &H0 And IID.Data4(6) = &H0 And IID.Data4(7) = &H46 Then
  521.             pvObj = VarPtr(This)
  522.             IEnumVARIANT_AddRef This
  523.             IEnumVARIANT_QueryInterface = S_OK
  524.         Else
  525.             IEnumVARIANT_QueryInterface = E_NOINTERFACE
  526.         End If
  527.     Else
  528.         IEnumVARIANT_QueryInterface = E_NOINTERFACE
  529.     End If
  530. End Function

  531. Private Function IEnumVARIANT_AddRef(ByRef This As VTableIEnumVARIANTDataStruct) As Long
  532.     This.RefCount = This.RefCount + 1
  533.     IEnumVARIANT_AddRef = This.RefCount
  534. End Function

  535. Private Function IEnumVARIANT_Release(ByRef This As VTableIEnumVARIANTDataStruct) As Long
  536.     This.RefCount = This.RefCount - 1
  537.     IEnumVARIANT_Release = This.RefCount
  538.     If IEnumVARIANT_Release = 0 Then
  539.         Set This.Enumerable = Nothing
  540.         CoTaskMemFree VarPtr(This)
  541.     End If
  542. End Function

  543. Private Function IEnumVARIANT_Next(ByRef This As VTableIEnumVARIANTDataStruct, ByVal VntCount As Long, ByVal VntArrPtr As Long, ByRef pcvFetched As Long) As Long
  544.     If VntArrPtr = 0 Then
  545.         IEnumVARIANT_Next = E_INVALIDARG
  546.         Exit Function
  547.     End If
  548.     On Error GoTo CATCH_EXCEPTION
  549.     Const VARIANT_CB As Long = 16
  550.     Dim Fetched As Long
  551.     With This
  552.         Do Until .Index > .Count
  553.             VariantCopyToPtr VntArrPtr, .Enumerable(.Index)
  554.             .Index = .Index + 1
  555.             Fetched = Fetched + 1
  556.             If Fetched = VntCount Then Exit Do
  557.             VntArrPtr = UnsignedAdd(VntArrPtr, VARIANT_CB)
  558.         Loop
  559.     End With
  560.     If Fetched = VntCount Then
  561.         IEnumVARIANT_Next = S_OK
  562.     Else
  563.         IEnumVARIANT_Next = S_FALSE
  564.     End If
  565.     If VarPtr(pcvFetched) <> 0 Then pcvFetched = Fetched
  566.     Exit Function
  567. CATCH_EXCEPTION:
  568.     If VarPtr(pcvFetched) <> 0 Then pcvFetched = 0
  569.     IEnumVARIANT_Next = E_NOTIMPL
  570. End Function

  571. Private Function IEnumVARIANT_Skip(ByRef This As VTableIEnumVARIANTDataStruct, ByVal VntCount As Long) As Long
  572.     IEnumVARIANT_Skip = E_NOTIMPL
  573. End Function

  574. Private Function IEnumVARIANT_Reset(ByRef This As VTableIEnumVARIANTDataStruct) As Long
  575.     IEnumVARIANT_Reset = E_NOTIMPL
  576. End Function

  577. Private Function IEnumVARIANT_Clone(ByRef This As VTableIEnumVARIANTDataStruct, ByRef ppEnum As IEnumVARIANT) As Long
  578.     IEnumVARIANT_Clone = E_NOTIMPL
  579. End Function

  580. Private Function GetHiddenMainWindow() As Long
  581.     EnumThreadWindows App.ThreadID, AddressOf EnumThreadWndProc, VarPtr(GetHiddenMainWindow)
  582. End Function

  583. Private Function EnumThreadWndProc(ByVal hwnd As Long, ByVal lpResult As Long) As Long
  584.     Dim ClassName As String
  585.     EnumThreadWndProc = 1
  586.     If GetWindowLong(hwnd, GWL_HWNDPARENT) = 0 Then
  587.         ClassName = GetWindowClassName(hwnd)
  588.         If InStr(ClassName, "Thunder") = 1 Then
  589.             If InStr(ClassName, "Main") = (Len(ClassName) - 3) Then
  590.                 CopyMemory ByVal lpResult, hwnd, 4
  591.                 EnumThreadWndProc = 0
  592.             End If
  593.         End If
  594.     End If
  595. End Function
复制代码
WavFilePlaying.bas
  1. Private Declare Function sndPlaySoundFromMemory Lib "winmm.dll" Alias "sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long) As Long
  2. Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
  3. Private Declare Function sndPlaySoundStop Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As Long, ByVal uFlags As Long) As Long
  4. Const SND_SYNC = &H0
  5. Const SND_ASYNC = &H1
  6. Const SND_NODEFAULT = &H2
  7. Const SND_MEMORY = &H4
  8. Const SND_LOOP = &H8
  9. ' SND_SYNC(=&H0)       同步调用,声音播放完毕   程序才能继续
  10. ' SND_ASYNC(=&H1)     非同步调用,不必等声音播放完毕   程序即可继续
  11. ' SND_NODEFAULT(=&H2)当声音文件未找到就停止播音返回
  12. ' SND_MEMORY(&H4)       播放内存中的声音
  13. ' SND_LOOP(=&H8)       声音播放完毕后   从头重复播放   与SND_ASYNC(=&H1)使用
  14. ' SND_NOSTOP(=&H10)   如果其他声音正在播放   则不终止该声音的播放,而返回False

  15. '从资源中播放声音
  16. Public Sub PlaySoundFromRES(ByVal ResID As Byte)
  17. StopSound
  18. Dim bArr() As Byte
  19. bArr = LoadResData(ResID, "CUSTOM")
  20. sndPlaySoundFromMemory bArr(0), SND_ASYNC Or SND_NODEFAULT Or SND_MEMORY
  21. End Sub

  22. '从文件播放声音
  23. Public Sub PlaySoundFromFile(ByVal FilePath As String, Optional ByVal ByASYNC As Boolean = True)
  24. sndPlaySound FilePath, IIf(ByASYNC, SND_ASYNC, SND_SYNC)
  25. End Sub

  26. '停止播放
  27. Public Sub StopSound()
  28. sndPlaySoundStop 0, SND_SYNC
  29. End Sub
复制代码
TransparentWindowAndStickedWindow.bas
  1. Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crkey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
  2. Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  3. Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  4. 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

  5. Public Const WS_EX_LAYERED = &H80000
  6. Public Const GWL_EXSTYLE = (-20)
  7. Public Const LWA_ALPHA = &H2                                                    '透明度有效,透明颜色无效
  8. Public Const LWA_COLORKEY = &H1                                                 '透明度无效,透明颜色有效
  9. Public Const SWP_NOSIZE = &H1
  10. Public Const SWP_NOMOVE = &H2
  11. Public Const HWND_TOPMOST = -1                                                  '置顶
  12. Public Const HWND_NOTOPMOST = -2                                                '取消置顶

  13. Public Sub StickWindow(ByRef ObjForm As Form)
  14.     SetWindowPos ObjForm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE '设置窗口置顶
  15. End Sub

  16. Public Sub UnstickWindow(ByRef ObjForm As Form)
  17.     SetWindowPos ObjForm.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE '取消窗口置顶
  18. End Sub

  19. Public Function TransparentByColor(ByVal TransparentColor As OLE_COLOR, ByVal ObjForm As Form) As Boolean
  20.     On Error GoTo ExitFunction
  21.     Dim rtn As Long, hwnd As Long
  22.     hwnd = ObjForm.hwnd
  23.     rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
  24.     rtn = rtn Or WS_EX_LAYERED
  25.     SetWindowLong hwnd, GWL_EXSTYLE, rtn
  26.     SetLayeredWindowAttributes hwnd, TransparentColor, 255, LWA_COLORKEY        '透明颜色
  27.     TransparentByColor = True
  28.     Exit Function
  29.    
  30. ExitFunction:
  31.     TransparentByColor = False
  32. End Function

  33. Public Function TransparentByTsprc(ByVal Transparency As Byte, ByVal ObjForm As Form) As Boolean
  34.     On Error GoTo ExitFunction
  35.     Dim rtn As Long, hwnd As Long
  36.     hwnd = ObjForm.hwnd
  37.     rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
  38.     rtn = rtn Or WS_EX_LAYERED
  39.     SetWindowLong hwnd, GWL_EXSTYLE, rtn
  40.     SetLayeredWindowAttributes hwnd, 0, Transparency, LWA_ALPHA                 '透明度
  41.     TransparentByTsprc = True
  42.     Exit Function
  43.    
  44. ExitFunction:
  45.     TransparentByTsprc = False
  46. End Function

  47. Public Function TransparentByValue(ByVal Value As Integer, ByVal ObjForm As Form) As Boolean
  48.     Select Case Value
  49.     Case Is <= 0
  50.         TransparentByTsprc 0, ObjForm
  51.     Case Is >= 100
  52.         TransparentByTsprc 255, ObjForm
  53.     Case Else
  54.         Dim tAlpha As Integer
  55.         tAlpha = Int(255 * Value / 100)
  56.         TransparentByTsprc CByte(tAlpha), ObjForm
  57.     End Select
  58. End Function
复制代码
Universal.bas
  1. Public Note() As String, NoteIndex As Long, NoteTotal As Long
  2. Public AutoRun As Boolean                                                       '开机自启动
  3. Public CurrIndex As Long '当前编辑的便笺索引
  4. Public IsTally As Boolean '是否在记账状态
  5. Public Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Integer, lpWSAData As WSADATA) As Long
  6. Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
  7. Public Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHostname As String) As Long
  8. Public Const WS_VERSION_REQD = &H101
  9. Public Declare Sub InitCommonControls Lib "comctl32" ()
  10. Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  11. Public Todo() As tTodo, TodoIndex As Long, R As Long, TodoTotal As Long
  12. Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
  13. ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

  14. Public Type tTodo
  15.     Title As String '内容
  16.     TTime As String
  17.     State As eState '表示待办的状态,分为计时中、已完成和待完成(无计时)三种状态值
  18.     Action As eAction '表示执行的动作枚举
  19.     ExtraInfo As String '动作额外参数,这跟动作有关联
  20. End Type

  21. Public Type WSADATA
  22.     wversion As Integer
  23.     wHighVersion As Integer
  24.     szDescription(0 To 256) As Byte
  25.     szSystemStatus(0 To 128) As Byte
  26.     iMaxSockets As Integer
  27.     iMaxUdpDg As Integer
  28.     lpszVendorInfo As Long
  29. End Type

  30. Public Enum eState '代办状态
  31.     Timing = 0 '计时中
  32.     Done = 1 '已完成
  33.     Unfinished = 2 '待完成(无计时)
  34. End Enum

  35. Public Enum eAction '动作
  36.     PowerOption = 0
  37.     ShowPrompt = 1
  38.     PlayMusic = 2
  39.     OpenFile = 3
  40.     ExecuteCommand = 4
  41. End Enum

  42. Public Function 减一秒(ByVal OTime As String) As String
  43. '因为只有倒计时才需要减一秒,所以前面必为 -
  44. Dim HH%, MM%, SS%
  45. '时间格式为-xx:xx:xx
  46. HH = Val(Mid(OTime, 2, 2))
  47. MM = Val(Mid(OTime, 5, 2))
  48. SS = Val(Mid(OTime, 8, 2))
  49. 'Debug.Print HH; " "; MM; " "; SS
  50. SS = SS - 1
  51. If SS = -1 Then SS = 59: MM = MM - 1
  52. If MM = -1 Then MM = 59: HH = HH - 1
  53. If HH = 0 And MM = 0 And SS = 0 Then
  54. 减一秒 = "-**:**:**" '表示时间停止
  55. Else
  56. 减一秒 = "-" & Format(HH, "00") & ":" & Format(MM, "00") & ":" & Format(SS, "00")
  57. End If
  58. End Function

  59. '检测网络连接
  60. Public Function IsConnectedState() As Boolean '检测网络连接
  61.     Dim udtWSAD As WSADATA
  62.     Call WSAStartup(WS_VERSION_REQD, udtWSAD)
  63.     IsConnectedState = CBool(gethostbyname("translate.google.cn"))
  64.     Call WSACleanup
  65. End Function

  66. '从字符串左侧取出基于字符长度的字符串
  67. Public Function SetTextLengthFromLeft(ByVal strText As String, ByVal Length As Long) As String
  68.     If Length <= 0 Then                                                         '长度不为负数
  69.         MsgBox "SetTextLengthFromLeft的Length不能小于1!", vbCritical
  70.         SetTextLengthFromLeft = ""
  71.         Exit Function
  72.     End If
  73.     Dim LengthTotal As Long, t As Long
  74.     LengthTotal = GetTextLengthA(strText)                                       '获得总长度
  75.     If Length > LengthTotal Then
  76.         '要提取的字符串比源字符串长,则全部输出
  77.         SetTextLengthFromLeft = strText
  78.     Else
  79.         Dim strTemp As String, i As Long, strChar As String, currL As Long
  80.         For i = 1 To Len(strText)
  81.             strChar = Mid(strText, i, 1)                                        '提取单个字符
  82.             If GetTextLengthA(strChar) = 1 Then                                 '英文字符
  83.                 currL = currL + 1
  84.                 If currL = Length Then                                          '刚刚好相等
  85.                     strTemp = strTemp & strChar
  86.                     Exit For
  87.                 ElseIf currL < Length Then                                      '还需要字符
  88.                     strTemp = strTemp & strChar
  89.                 End If
  90.             ElseIf GetTextLengthA(strChar) = 2 Then                             '中文字符
  91.                 currL = currL + 2
  92.                 If currL = Length Then                                          '刚刚好相等
  93.                     strTemp = strTemp & strChar
  94.                     Exit For
  95.                 ElseIf currL < Length Then                                      '还需要字符
  96.                     strTemp = strTemp & strChar
  97.                 ElseIf currL > Length Then                                      '字符数超过,例如需要21个字符时,最后一个是汉字
  98.                     Exit For
  99.                 End If
  100.             End If
  101.         Next i
  102.         SetTextLengthFromLeft = strTemp
  103.     End If
  104. End Function

  105. '判断一个Ansi字符串的长度
  106. '一个中文字符长度为2,一个英文字符长度为1
  107. Public Function GetTextLengthA(ByVal strText As String) As Double
  108.     Dim intX As Double
  109.     Dim lngTextLength As Double
  110.     lngTextLength = Len(strText)                                                '返回Unicode的长度
  111.     For intX = 1 To lngTextLength
  112.         'Asc():英文字符(除了大写W)返回值大于零,中文字符返回值小于零
  113.         If Asc(Mid$(strText, intX, 1)) < 0 Or Mid$(strText, intX, 1) = "W" Then lngTextLength = lngTextLength + 1
  114.     Next
  115.     GetTextLengthA = lngTextLength
  116. End Function

  117. Public Sub ShowMessage(Message As String, Title As String)
  118. Load FrmMessage
  119. FrmMessage.LblMessage.Caption = Message
  120. FrmMessage.LblFormTitle.Caption = Title
  121. FrmMessage.Show 1
  122. End Sub

  123. Public Sub ShowMusicAlert(TodoID As Long)
  124. Load FrmMusic
  125. FrmMusic.Tag = CStr(TodoID)
  126. FrmMusic.WMP.url = Todo(TodoID).ExtraInfo
  127. FrmMusic.LblFormTitle.Caption = "提醒"
  128. FrmMusic.Show 1
  129. End Sub

  130. '运行/打开文件
  131. Public Sub RunFile(FilePath As String)
  132. If Dir(FilePath) = "" Then Exit Sub
  133. Dim Suffix As String, FileFolder As String, FileName As String
  134. Suffix = LCase(Right(FilePath, Len(FilePath) - InStrRev(FilePath, "."))) '获得文件后缀
  135. FileFolder = Left(FilePath, InStrRev(FilePath, "\"))
  136. If Right(FileFolder, 1) <> "\" Then FileFolder = FileFolder & "\" '获得文件夹
  137. FileName = Right(FilePath, Len(FilePath) - Len(FileFolder)) '获得文件名
  138. Select Case Suffix
  139.     Case "bat", "exe"
  140.     Shell FilePath, vbNormalFocus
  141.     Case "py"
  142.     Shell "python " & FilePath, vbNormalFocus
  143.     Case "java"
  144.     Open FileFolder & "RunBat.bat" For Output As #2
  145.     Print #2, "@echo off"
  146.     Print #2, Left(FileFolder, 2)
  147.     Print #2, "cd " & Left(FileFolder, Len(FileFolder) - 1)
  148.     Print #2, "javac " & FileName
  149.     Print #2, "java " & Left(FileName, Len(FileName) - 5)
  150. '    MsgBox Left(FileName, Len(FileName) - 5)
  151.     Print #2, "del " & Left(FileName, Len(FileName) - 5) & ".class"
  152.     Print #2, "del %0"
  153.     Close #2
  154.     Sleep 50
  155.     Shell FileFolder & "RunBat.bat", vbNormalFocus
  156.     Case "jar"
  157.     Shell "java -jar " & FilePath, vbNormalFocus
  158.     Case Else
  159.     ShellExecute FrmMain.hwnd, "open", FilePath, vbNullString, vbNullString, 1
  160. End Select
  161. End Sub
复制代码
MouseWheelSupport.bas
  1. 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
  2. Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  3. Public Const GWL_WNDPROC = (-4)
  4. Public Const WM_MOUSEWHEEL = &H20A
  5. Public PrevWndProc As Long

  6. Public Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '‘写自己处理鼠标滚动的事件,这里让Form上下滚动
  7.     Dim t(0 To 1) As Integer
  8.     If uMsg = WM_MOUSEWHEEL Then
  9.         If wParam < 0 Then                                                      '滚轮向下
  10.             Call WheelDown
  11.         Else                                                                    '滚轮向上
  12.             Call WheelUp
  13.         End If
  14.     Else
  15.         WndProc = CallWindowProc(PrevWndProc, hwnd, uMsg, wParam, lParam)       '‘让Windows处理其他事件
  16.     End If
  17. End Function

  18. '滚轮向下的事件
  19. Public Sub WheelDown()
  20.     Debug.Print "滚轮向下"
  21.     If FrmMain.TxtHour.Tag = "1" And Val(FrmMain.TxtHour.Text) < 23 Then FrmMain.TxtHour.Text = Format(Val(FrmMain.TxtHour.Text) + 1, "00")
  22.     If FrmMain.TxtMinute.Tag = "1" And Val(FrmMain.TxtMinute.Text) < 59 Then FrmMain.TxtMinute.Text = Format(Val(FrmMain.TxtMinute.Text) + 1, "00")

  23. End Sub

  24. '滚轮向上的事件
  25. Public Sub WheelUp()
  26.     Debug.Print "滚轮向上"
  27.     If FrmMain.TxtHour.Tag = "1" And Val(FrmMain.TxtHour.Text) > 0 Then FrmMain.TxtHour.Text = Format(Val(FrmMain.TxtHour.Text) - 1, "00")
  28.     If FrmMain.TxtMinute.Tag = "1" And Val(FrmMain.TxtMinute.Text) > 0 Then FrmMain.TxtMinute.Text = Format(Val(FrmMain.TxtMinute.Text) - 1, "00")
  29. End Sub

  30. ''将下列代码复制到窗体模块内,即可实现鼠标滚轮的响应。
  31. 'Private Sub Form_Load()
  32. '    PrevWndProc = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf WndProc)        '让WndProc来处理该窗体的事件
  33. 'End Sub
  34. '
  35. 'Private Sub Form_Unload(Cancel As Integer)
  36. '    Dim lResult As Long
  37. '    lResult = SetWindowLong(Me.hwnd, GWL_WNDPROC, PrevWndProc)                  '让Windows默认的函数来处理事件
  38. 'End Sub
复制代码
MovingWindowWithoutBorder.bas
  1. Public Declare Function ReleaseCapture Lib "user32" () As Long
  2. 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
  3. Public Const HTCAPTION = 2
  4. Public Const WM_NCLBUTTONDOWN = &HA1

  5. Public Sub MoveFormWithoutBorder(ByVal ObjForm As Form)
  6.     '此函数在MouseDown中调用
  7.     ReleaseCapture
  8.     SendMessage ObjForm.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
  9. End Sub
复制代码
ReadingAndWritingReg_AutoStartAfterSystemLoginedIncluded
  1. '---------------------------------------------------------------
  2. '-注册表 API 声明...
  3. '---------------------------------------------------------------

  4. '关闭登录关键字
  5. Public Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

  6. '建立关键字
  7. Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
  8. 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

  9. '打开关键字
  10. 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

  11. '返回关键字的类型和值
  12. 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
  13. 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
  14. 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

  15. '将文本字符串与指定关键字关联
  16. 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
  17. 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
  18. 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

  19. '删除关键字
  20. Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long

  21. '从登录关键字中删除一个值
  22. Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long

  23. ' 注册表的数据类型
  24. Public Enum REGValueType

  25.     REG_SZ = 1                                                                  ' Unicode空终结字符串
  26.     REG_EXPAND_SZ = 2                                                           ' Unicode空终结字符串
  27.     REG_BINARY = 3                                                              ' 二进制数值
  28.     REG_DWORD = 4                                                               ' 32-bit 数字
  29.     REG_DWORD_BIG_ENDIAN = 5
  30.     REG_LINK = 6
  31.     REG_MULTI_SZ = 7                                                            ' 二进制数值串

  32. End Enum

  33. ' 注册表创建类型值...
  34. Const REG_OPTION_NON_VOLATILE = 0                                               ' 当系统重新启动时,关键字被保留

  35. ' 注册表关键字安全选项...
  36. Const READ_CONTROL = &H20000
  37. Const KEY_QUERY_VALUE = &H1
  38. Const KEY_SET_VALUE = &H2
  39. Const KEY_CREATE_SUB_KEY = &H4
  40. Const KEY_ENUMERATE_SUB_KEYS = &H8
  41. Const KEY_NOTIFY = &H10
  42. Const KEY_CREATE_LINK = &H20
  43. Const KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
  44. Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
  45. Const KEY_EXECUTE = KEY_READ
  46. Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
  47.     KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
  48.     KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL

  49.     ' 注册表关键字根类型...
  50. Public Enum REGRoot

  51.     HKEY_CLASSES_ROOT = &H80000000
  52.     HKEY_CURRENT_USER = &H80000001
  53.     HKEY_LOCAL_MACHINE = &H80000002
  54.     HKEY_USERS = &H80000003
  55.     HKEY_PERFORMANCE_DATA = &H80000004

  56. End Enum

  57. ' 返回值...
  58. Const ERROR_NONE = 0
  59. Const ERROR_BADKEY = 2
  60. Const ERROR_ACCESS_DENIED = 8
  61. Const ERROR_SUCCESS = 0

  62. '- 注册表安全属性类型...
  63. Public Type SECURITY_ATTRIBUTES

  64.     nLength As Long
  65.     lpSecurityDescriptor As Long
  66.     bInheritHandle As Boolean

  67. End Type

  68. '*************************************************************************
  69. '**函 数 名:WriteRegKey
  70. '**输    入:ByVal KeyRoot(REGRoot)         - 根
  71. '**        :ByVal KeyName(String)          - 键的路径
  72. '**        :ByVal SubKeyName(String)       - 键名
  73. '**        :ByVal SubKeyType(REGValueType) - 键的类型
  74. '**        :ByVal SubKeyValue(String)      - 键值
  75. '**输    出:(Boolean) - 成功返回True,失败返回False
  76. '**功能描述:写注册表
  77. '**全局变量:
  78. '**调用模块:
  79. '**作    者:叶帆
  80. '**日    期:2003年01月10日
  81. '**修 改 人:
  82. '**日    期:
  83. '**版    本:版本1.0
  84. '*************************************************************************

  85. 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
  86.    
  87.     Dim RC As Long                                                              ' 返回代码
  88.     Dim hKey As Long                                                            ' 处理一个注册表关键字
  89.     Dim hDepth As Long                                                          ' 用于装载下列某个常数的一个变量
  90.     ' REG_CREATED_NEW_KEY——新建的一个子项
  91.     ' REG_OPENED_EXISTING_KEY——打开一个现有的项
  92.     Dim lpAttr As SECURITY_ATTRIBUTES                                           ' 注册表安全类型
  93.     Dim i As Integer
  94.     Dim bytValue(1024) As Byte
  95.    
  96.     lpAttr.nLength = 50                                                         ' 设置安全属性为缺省值...
  97.     lpAttr.lpSecurityDescriptor = 0                                             ' ...
  98.     lpAttr.bInheritHandle = True                                                ' ...
  99.    
  100.     '- 创建/打开注册表关键字...
  101.     RC = RegCreateKeyEx(KeyRoot, KeyName, 0, SubKeyType, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, lpAttr, hKey, hDepth) ' 创建/打开//KeyRoot//KeyName
  102.    
  103.     If (RC <> ERROR_SUCCESS) Then GoTo CreateKeyError                           ' 错误处理...
  104.    
  105.     '- 创建/修改关键字值...
  106.    
  107.     If (SubKeyValue = "") Then SubKeyValue = " "                                ' 要让RegSetValueEx() 工作需要输入一个空格...
  108.    
  109.     Select Case SubKeyType                                                      ' 搜索数据类型...
  110.         
  111.     Case REG_SZ, REG_EXPAND_SZ                                                  ' 字符串注册表关键字数据类型
  112.         
  113.         RC = RegSetValueEx_SZ(hKey, SubKeyName, 0, SubKeyType, ByVal SubKeyValue, LenB(StrConv(SubKeyValue, vbFromUnicode)))
  114.         
  115.         If (RC <> ERROR_SUCCESS) Then GoTo CreateKeyError                       ' 错误处理
  116.         
  117.     Case REG_DWORD                                                              ' 四字节注册表关键字数据类型
  118.         
  119.         RC = RegSetValueEx_DWORD(hKey, SubKeyName, 0, SubKeyType, Val("&h" + SubKeyValue), 4)
  120.         
  121.         If (RC <> ERROR_SUCCESS) Then GoTo CreateKeyError                       ' 错误处理
  122.         
  123.     Case REG_BINARY                                                             ' 二进制字符串
  124.         
  125.         Dim intNum As Integer
  126.         
  127.         For i = 1 To Len(Trim$(SubKeyValue)) - 1 Step 3
  128.             
  129.             intNum = intNum + 1
  130.             bytValue(intNum - 1) = Val("&h" + Mid$(SubKeyValue, i, 2))
  131.             
  132.         Next i
  133.         
  134.         RC = RegSetValueEx_BINARY(hKey, SubKeyName, 0, SubKeyType, bytValue(0), intNum)
  135.         
  136.         If (RC <> ERROR_SUCCESS) Then GoTo CreateKeyError                       ' 错误处理
  137.         
  138.     Case Else
  139.         
  140.         GoTo CreateKeyError                                                     ' 错误处理
  141.         
  142.     End Select
  143.    
  144.     '- 关闭注册表关键字...
  145.     RC = RegCloseKey(hKey)                                                      ' 关闭关键字
  146.    
  147.     WriteRegKey = True                                                          ' 返回成功
  148.    
  149.     Exit Function                                                               ' 退出
  150.    
  151. CreateKeyError:
  152.    
  153.     WriteRegKey = False                                                         ' 设置错误返回代码
  154.     RC = RegCloseKey(hKey)                                                      ' 试图关闭关键字
  155.    
  156. End Function

  157. '*************************************************************************
  158. '**函 数 名:ReadRegKey
  159. '**输    入:KeyRoot(Long)     - 根
  160. '**        :KeyName(String)   - 键的路径
  161. '**        :SubKeyRef(String) - 键名
  162. '**输    出:(String) - 返回键值
  163. '**功能描述:读注册表
  164. '**全局变量:
  165. '**调用模块:
  166. '**作    者:叶帆
  167. '**日    期:2003年01月10日
  168. '**修 改 人:
  169. '**日    期:
  170. '**版    本:版本1.0
  171. '*************************************************************************

  172. Public Function ReadRegKey(ByVal KeyRoot As REGRoot, ByVal KeyName As String, ByVal SubKeyName As String) As String
  173.    
  174.     Dim i As Long                                                               ' 循环计数器
  175.     Dim RC As Long                                                              ' 返回代码
  176.     Dim hKey As Long                                                            ' 处理打开的注册表关键字
  177.     Dim hDepth As Long                                                          '
  178.     Dim sKeyVal As String
  179.     Dim lKeyValType As Long                                                     ' 注册表关键字数据类型
  180.     Dim tmpVal As String                                                        ' 注册表关键字的临时存储器
  181.     Dim KeyValSize As Long                                                      ' 注册表关键字变量尺寸
  182.     Dim LngValue As Long
  183.     Dim bytValue(1024) As Byte
  184.    
  185.     ' 在 KeyRoot下打开注册表关键字
  186.    
  187.     RC = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey)                ' 打开注册表关键字
  188.    
  189.     If (RC <> ERROR_SUCCESS) Then GoTo GetKeyError                              ' 处理错误...
  190.    
  191.     ' 检测键的类型
  192.    
  193.     RC = RegQueryValueEx(hKey, SubKeyName, 0, lKeyValType, ByVal 0, KeyValSize) ' 获得/创建关键字的值lKeyValType
  194.    
  195.     If (RC <> ERROR_SUCCESS) Then GoTo GetKeyError                              ' 处理错误...
  196.    
  197.     '读相应的键值
  198.    
  199.     Select Case lKeyValType                                                     ' 搜索数据类型...
  200.         
  201.     Case REG_SZ, REG_EXPAND_SZ                                                  ' 字符串注册表关键字数据类型
  202.         
  203.         tmpVal = String$(1024, 0)                                               ' 分配变量空间
  204.         KeyValSize = 1024                                                       ' 标记变量尺寸
  205.         
  206.         RC = RegQueryValueEx_SZ(hKey, SubKeyName, 0, 0, tmpVal, KeyValSize)     ' 获得/创建关键字的值
  207.         
  208.         If RC <> ERROR_SUCCESS Then GoTo GetKeyError                            ' 错误处理
  209.         
  210.         If InStr(tmpVal, Chr$(0)) > 0 Then sKeyVal = Left$(tmpVal, InStr(tmpVal, Chr$(0)) - 1) ' 复制字符串的值,并去除空字符.
  211.         
  212.     Case REG_DWORD                                                              ' 四字节注册表关键字数据类型
  213.         
  214.         KeyValSize = 1024                                                       ' 标记变量尺寸
  215.         RC = RegQueryValueEx_DWORD(hKey, SubKeyName, 0, 0, LngValue, KeyValSize) ' 获得/创建关键字的值
  216.         
  217.         If RC <> ERROR_SUCCESS Then GoTo GetKeyError                            ' 错误处理
  218.         
  219.         sKeyVal = "0x" + Hex$(LngValue)
  220.         
  221.     Case REG_BINARY                                                             ' 二进制字符串
  222.         
  223.         RC = RegQueryValueEx(hKey, SubKeyName, 0, 0, bytValue(0), KeyValSize)   ' 获得/创建关键字的值
  224.         
  225.         If RC <> ERROR_SUCCESS Then GoTo GetKeyError                            ' 错误处理
  226.         
  227.         sKeyVal = ""
  228.         
  229.         For i = 1 To KeyValSize
  230.             
  231.             If Len(Hex$(bytValue(i - 1))) = 1 Then
  232.                
  233.                 sKeyVal = sKeyVal + "0" + Hex$(bytValue(i - 1)) + " "
  234.                
  235.             Else
  236.                
  237.                 sKeyVal = sKeyVal + Hex$(bytValue(i - 1)) + " "
  238.                
  239.             End If
  240.             
  241.         Next i
  242.         
  243.     Case Else
  244.         
  245.         sKeyVal = ""
  246.         
  247.     End Select
  248.    
  249.     ReadRegKey = sKeyVal                                                        ' 返回值
  250.     RC = RegCloseKey(hKey)                                                      ' 关闭注册表关键字
  251.    
  252.     Exit Function                                                               ' 退出
  253.    
  254. GetKeyError:
  255.    
  256.     ' 错误发生过后进行清除...
  257.    
  258.     ReadRegKey = ""                                                             ' 设置返回值为错误
  259.    
  260.     RC = RegCloseKey(hKey)                                                      ' 关闭注册表关键字
  261.    
  262. End Function

  263. '*************************************************************************
  264. '**函 数 名:DelRegKey
  265. '**输    入:KeyRoot(Long)     - 根
  266. '**        :KeyName(String)   - 键的路径
  267. '**        :SubKeyRef(String) - 键名
  268. '**输    出:(Long) - 状态码
  269. '**功能描述:删除关键字
  270. '**全局变量:
  271. '**调用模块:
  272. '**作    者:叶帆
  273. '**日    期:2003年01月11日
  274. '**修 改 人:
  275. '**日    期:
  276. '**版    本:版本1.0
  277. '*************************************************************************

  278. Public Function DelRegKey(ByVal KeyRoot As REGRoot, ByVal KeyName As String, ByVal SubKeyName As String) As Long
  279.    
  280.     Dim lKeyId          As Long
  281.     Dim lResult         As Long
  282.    
  283.     '检测设置的参数
  284.     If Len(KeyName) = 0 And Len(SubKeyName) = 0 Then
  285.         
  286.         ' 键值没设置则返回相应错误码
  287.         DelRegKey = ERROR_BADKEY
  288.         
  289.         Exit Function
  290.         
  291.     End If
  292.    
  293.     ' 打开关键字并尝试创建它,如果已存在,则返回ID值
  294.     lResult = RegCreateKey(KeyRoot, KeyName, lKeyId)
  295.    
  296.     If lResult = 0 Then
  297.         
  298.         '删除关键字
  299.         DelRegKey = RegDeleteKey(lKeyId, ByVal SubKeyName)
  300.         
  301.     End If
  302.    
  303. End Function

  304. '*************************************************************************
  305. '**函 数 名:DelRegValue
  306. '**输    入:KeyRoot(Long)     - 根
  307. '**        :KeyName(String)   - 键的路径
  308. '**        :SubKeyRef(String) - 键名
  309. '**输    出:(Long) - 状态码
  310. '**功能描述:从登录关键字中删除一个值
  311. '**全局变量:
  312. '**调用模块:
  313. '**作    者:叶帆
  314. '**日    期:2003年01月11日
  315. '**修 改 人:
  316. '**日    期:
  317. '**版    本:版本1.0
  318. '*************************************************************************

  319. Public Function DelRegValue(ByVal KeyRoot As REGRoot, ByVal KeyName As String, ByVal SubKeyName As String) As Long
  320.    
  321.     Dim lKeyId As Long
  322.     Dim lResult As Long
  323.    
  324.     '检测设置的参数
  325.     If Len(KeyName) = 0 And Len(SubKeyName) = 0 Then
  326.         
  327.         ' 键值没设置则返回相应错误码
  328.         DelRegValue = ERROR_BADKEY
  329.         
  330.         Exit Function
  331.         
  332.     End If
  333.    
  334.     ' 打开关键字并尝试创建它,如果已存在,则返回ID值
  335.     lResult = RegCreateKey(KeyRoot, KeyName, lKeyId)
  336.    
  337.     If lResult = 0 Then
  338.         
  339.         '从登录关键字中删除一个值
  340.         DelRegValue = RegDeleteValue(lKeyId, ByVal SubKeyName)
  341.         
  342.     End If
  343.    
  344. End Function

  345. Public Sub AddStart()                                                           '增加开机启动项
  346.     WriteRegKey HKEY_LOCAL_MACHINE, ByVal "Software\Microsoft\Windows\CurrentVersion\Run", ByVal App.EXEName, REG_SZ, ByVal App.Path & "\" & App.EXEName & ".exe"
  347.     'WriteRegKey 主键              , ByVal 路径                                           , ByVal 名称       , 类型  , ByVal 数据
  348. End Sub

  349. Public Sub DeleteStart()                                                        '删除开机启动项
  350.     DelRegValue HKEY_LOCAL_MACHINE, ByVal "Software\Microsoft\Windows\CurrentVersion\Run", ByVal App.EXEName
  351. End Sub
复制代码
CommonDialog.cls
  1. Option Explicit
  2. #If False Then
  3. Private CdlCancel, CdlBufferTooSmall, CdlInvalidFileName, CdlSubclassFailure, CdlMaxLessThanMin, CdlNoFonts, CdlPrinterNotFound, CdlCreateICFailure, CdlDndmMismatch, CdlNoDefaultPrn, CdlNoDevices, CdlInitFailure, CdlGetDevModeFail, CdlLoadDrvFailure, CdlRetDefFailure, CdlParseFailure, CdlHelp, CdlBufferLengthZero
  4. Private CdlPRORPortrait, CdlPRORLandscape
  5. 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
  6. Private CdlPRBNUpper, CdlPRBNLower, CdlPRBNMiddle, CdlPRBNManual, CdlPRBNEnvelope, CdlPRBNEnvManual, CdlPRBNAuto, CdlPRBNTractor, CdlPRBNSmallFmt, CdlPRBNLargeFmt, CdlPRBNLargeCapacity, CdlPRBNCassette
  7. Private CdlPRPQHigh, CdlPRPQMedium, CdlPRPQLow, CdlPRPQDraft
  8. Private CdlPRCMMonochrome, CdlPRCMColor
  9. Private CdlPRDPSimplex, CdlPRDPHorizontal, CdlPRDPVertical
  10. Private CdlOFNReadOnly, CdlOFNOverwritePrompt, CdlOFNHideReadOnly, CdlOFNNoChangeDir, CdlOFNHelpButton, CdlOFNNoValidate, CdlOFNAllowMultiSelect, CdlOFNExtensionDifferent, CdlOFNPathMustExist, CdlOFNFileMustExist, CdlOFNCreatePrompt, CdlOFNShareAware, CdlOFNNoReadOnlyReturn, CdlOFNNoNetworkButton, CdlOFNExplorer, CdlOFNNoDereferenceLinks, CdlOFNDontAddToRecent, CdlOFNForcesShowHidden
  11. Private CdlOFNShareViResultWarn, CdlOFNShareViResultNoWarn, CdlOFNShareViResultFallThrough
  12. Private CdlCCRGBInit, CdlCCFullOpen, CdlCCPreventFullOpen, CdlCCHelpButton, CdlCCSolidColor, CdlCCAnyColor
  13. Private CdlCFScreenFonts, CdlCFPrinterFonts, CdlCFHelpButton, CdlCFEffects, CdlCFApply, CdlCFScriptsOnly, CdlCFNoVectorFonts, CdlCFLimitSize, CdlCFFixedPitchOnly, CdlCFForceFontExist, CdlCFScalableOnly, CdlCFTTOnly, CdlCFNoFaceSel, CdlCFNoStyleSel, CdlCFNoSizeSel, CdlCFSelectScript, CdlCFNoScriptSel, CdlCFNoVertFonts
  14. Private CdlPDAllPages, CdlPDSelection, CdlPDPageNums, CdlPDNoSelection, CdlPDNoPageNums, CdlPDCollate, CdlPDPrintToFile, CdlPDPrintSetup, CdlPDNoWarning, CdlPDReturnDC, CdlPDReturnIC, CdlPDReturnDefault, CdlPDHelpButton, CdlPDUseDevModeCopies, CdlPDUseDevModeCopiesAndCollate, CdlPDDisablePrintToFile, CdlPDCurrentPage, CdlPDHidePrintToFile, CdlPDNoNetworkButton, CdlPDNoCurrentPage
  15. Private CdlPDResultCancel, CdlPDResultPrint, CdlPDResultApply
  16. Private CdlHelpContext, CdlHelpQuit, CdlHelpIndex, CdlHelpContents, CdlHelpHelpOnHelp, CdlHelpSetIndex, CdlHelpSetContents, CdlHelpContextPopup, CdlHelpForceFile, CdlHelpKey, CdlHelpCommandHelp, CdlHelpPartialKey
  17. Private CdlPSDDefaultMinMargins, CdlPSDMinMargins, CdlPSDMargins, CdlPSDInThousandthsOfInches, CdlPSDInHundredthsOfMillimeters, CdlPSDDisableMargins, CdlPSDDisablePrinter, CdlPSDNoWarning, CdlPSDDisableOrientation, CdlPSDDisablePaper, CdlPSDReturnDefault, CdlPSDHelpButton, CdlPSDDisablePagePainting, CdlPSDNoNetworkButton
  18. Private CdlBIFReturnOnlyFSDirs, CdlBIFDontGoBelowDomain, CdlBIFStatusText, CdlBIFReturnFSAncestors, CdlBIFEditBox, CdlBIFValidate, CdlBIFNewDialogStyle, CdlBIFBrowseIncludeURLs, CdlBIFUseNewUI, CdlBIFUAHint, CdlBIFNoNewFolderButton, CdlBIFNoTranslateTargets, CdlBIFBrowseForComputer, CdlBIFBrowseForPrinter, CdlBIFBrowseIncludeFiles, CdlBIFShareable, CdlBIFBrowseFileJunctions
  19. Private CdlFRDown, CdlFRWholeWord, CdlFRMatchCase, CdlFRFindNext, CdlFRReplace, CdlFRReplaceAll, CdlFRHelpButton, CdlFRNoUpDown, CdlFRNoMatchCase, CdlFRNoWholeWord, CdlFRHideUpDown, CdlFRHideMatchCase, CdlFRHideWholeWord
  20. Private CdlOAIFAllowRegistration, CdlOAIFRegisterExt, CdlOAIFExecute, CdlOAIFForceRegistration, CdlOAIFHideRegistration, CdlOAIFURLProtocol
  21. #End If
  22. Private Const FNERR_BUFFERTOOSMALL As Long = &H3003
  23. Private Const FNERR_INVALIDFILENAME As Long = &H3002
  24. Private Const FNERR_SUBCLASSFAILURE As Long = &H3001
  25. Private Const CFERR_MAXLESSTHANMIN As Long = &H2002
  26. Private Const CFERR_NOFONTS As Long = &H2001
  27. Private Const PDERR_PRINTERNOTFOUND As Long = &H100B
  28. Private Const PDERR_CREATEICFAILURE As Long = &H100A
  29. Private Const PDERR_DNDMMISMATCH As Long = &H1009
  30. Private Const PDERR_NODEFAULTPRN As Long = &H1008
  31. Private Const PDERR_NODEVICES As Long = &H1007
  32. Private Const PDERR_INITFAILURE As Long = &H1006
  33. Private Const PDERR_GETDEVMODEFAIL As Long = &H1005
  34. Private Const PDERR_LOADDRVFAILURE As Long = &H1004
  35. Private Const PDERR_RETDEFFAILURE As Long = &H1003
  36. Private Const PDERR_PARSEFAILURE As Long = &H1002
  37. Private Const FRERR_BUFFERLENGTHZERO As Long = &H4001
  38. Public Enum CdlErrorConstants
  39.     CdlCancel = 32755
  40.     CdlBufferTooSmall = 20476
  41.     CdlInvalidFileName = 20477
  42.     CdlSubclassFailure = 20478
  43.     CdlMaxLessThanMin = 24573
  44.     CdlNoFonts = 24574
  45.     CdlPrinterNotFound = 28660
  46.     CdlCreateICFailure = 28661
  47.     CdlDndmMismatch = 28662
  48.     CdlNoDefaultPrn = 28663
  49.     CdlNoDevices = 28664
  50.     CdlInitFailure = 28665
  51.     CdlGetDevModeFail = 28666
  52.     CdlLoadDrvFailure = 28667
  53.     CdlRetDefFailure = 28668
  54.     CdlParseFailure = 28669
  55.     CdlHelp = 32751
  56.     CdlBufferLengthZero = 36848
  57. End Enum
  58. Public Enum CdlPRORConstants
  59.     CdlPRORPortrait = vbPRORPortrait
  60.     CdlPRORLandscape = vbPRORLandscape
  61. End Enum
  62. Public Enum CdlPRPSConstants
  63.     CdlPRPSLetter = vbPRPSLetter
  64.     CdlPRPSLetterSmall = vbPRPSLetterSmall
  65.     CdlPRPSTabloid = vbPRPSTabloid
  66.     CdlPRPSLedger = vbPRPSLedger
  67.     CdlPRPSLegal = vbPRPSLegal
  68.     CdlPRPSStatement = vbPRPSStatement
  69.     CdlPRPSExecutive = vbPRPSExecutive
  70.     CdlPRPSA3 = vbPRPSA3
  71.     CdlPRPSA4 = vbPRPSA4
  72.     CdlPRPSA4Small = vbPRPSA4Small
  73.     CdlPRPSA5 = vbPRPSA5
  74.     CdlPRPSB4 = vbPRPSB4
  75.     CdlPRPSB5 = vbPRPSB5
  76.     CdlPRPSFolio = vbPRPSFolio
  77.     CdlPRPSQuarto = vbPRPSQuarto
  78.     CdlPRPS10x14 = vbPRPS10x14
  79.     CdlPRPS11x17 = vbPRPS11x17
  80.     CdlPRPSNote = vbPRPSNote
  81.     CdlPRPSEnv9 = vbPRPSEnv9
  82.     CdlPRPSEnv10 = vbPRPSEnv10
  83.     CdlPRPSEnv11 = vbPRPSEnv11
  84.     CdlPRPSEnv12 = vbPRPSEnv12
  85.     CdlPRPSEnv14 = vbPRPSEnv14
  86.     CdlPRPSCSheet = vbPRPSCSheet
  87.     CdlPRPSDSheet = vbPRPSDSheet
  88.     CdlPRPSESheet = vbPRPSESheet
  89.     CdlPRPSEnvDL = vbPRPSEnvDL
  90.     CdlPRPSEnvC5 = vbPRPSEnvC5
  91.     CdlPRPSEnvC3 = vbPRPSEnvC3
  92.     CdlPRPSEnvC4 = vbPRPSEnvC4
  93.     CdlPRPSEnvC6 = vbPRPSEnvC6
  94.     CdlPRPSEnvC65 = vbPRPSEnvC65
  95.     CdlPRPSEnvB4 = vbPRPSEnvB4
  96.     CdlPRPSEnvB5 = vbPRPSEnvB5
  97.     CdlPRPSEnvB6 = vbPRPSEnvB6
  98.     CdlPRPSEnvItaly = vbPRPSEnvItaly
  99.     CdlPRPSEnvMonarch = vbPRPSEnvMonarch
  100.     CdlPRPSEnvPersonal = vbPRPSEnvPersonal
  101.     CdlPRPSFanfoldUS = vbPRPSFanfoldUS
  102.     CdlPRPSFanfoldStdGerman = vbPRPSFanfoldStdGerman
  103.     CdlPRPSFanfoldLglGerman = vbPRPSFanfoldLglGerman
  104.     CdlPRPSUser = vbPRPSUser
  105. End Enum
  106. Public Enum CdlPRBNConstants
  107.     CdlPRBNUpper = vbPRBNUpper
  108.     CdlPRBNLower = vbPRBNLower
  109.     CdlPRBNMiddle = vbPRBNMiddle
  110.     CdlPRBNManual = vbPRBNManual
  111.     CdlPRBNEnvelope = vbPRBNEnvelope
  112.     CdlPRBNEnvManual = vbPRBNEnvManual
  113.     CdlPRBNAuto = vbPRBNAuto
  114.     CdlPRBNTractor = vbPRBNTractor
  115.     CdlPRBNSmallFmt = vbPRBNSmallFmt
  116.     CdlPRBNLargeFmt = vbPRBNLargeFmt
  117.     CdlPRBNLargeCapacity = vbPRBNLargeCapacity
  118.     CdlPRBNCassette = vbPRBNCassette
  119. End Enum
  120. Public Enum CdlPRPQConstants
  121.     CdlPRPQHigh = vbPRPQHigh
  122.     CdlPRPQMedium = vbPRPQMedium
  123.     CdlPRPQLow = vbPRPQLow
  124.     CdlPRPQDraft = vbPRPQDraft
  125. End Enum
  126. Public Enum CdlPRCMConstants
  127.     CdlPRCMMonochrome = vbPRCMMonochrome
  128.     CdlPRCMColor = vbPRCMColor
  129. End Enum
  130. Public Enum CdlPRDPConstants
  131.     CdlPRDPSimplex = vbPRDPSimplex
  132.     CdlPRDPHorizontal = vbPRDPHorizontal
  133.     CdlPRDPVertical = vbPRDPVertical
  134. End Enum
  135. Private Const OFN_READONLY As Long = &H1
  136. Private Const OFN_OVERWRITEPROMPT As Long = &H2
  137. Private Const OFN_HIDEREADONLY As Long = &H4
  138. Private Const OFN_NOCHANGEDIR As Long = &H8
  139. Private Const OFN_SHOWHELP As Long = &H10
  140. Private Const OFN_ENABLEHOOK As Long = &H20                                     ' Internal use only
  141. Private Const OFN_NOVALIDATE As Long = &H100
  142. Private Const OFN_ALLOWMULTISELECT As Long = &H200
  143. Private Const OFN_EXTENSIONDIFFERENT As Long = &H400
  144. Private Const OFN_PATHMUSTEXIST As Long = &H800
  145. Private Const OFN_FILEMUSTEXIST As Long = &H1000
  146. Private Const OFN_CREATEPROMPT As Long = &H2000
  147. Private Const OFN_SHAREAWARE As Long = &H4000
  148. Private Const OFN_NOREADONLYRETURN As Long = &H8000&
  149. Private Const OFN_NONETWORKBUTTON As Long = &H20000
  150. Private Const OFN_EXPLORER As Long = &H80000
  151. Private Const OFN_NODEREFERENCELINKS As Long = &H100000
  152. Private Const OFN_ENABLESIZING As Long = &H800000                               ' Internal use only. Necessary only if a callback procedure or custom template is provided
  153. Private Const OFN_DONTADDTORECENT As Long = &H2000000
  154. Private Const OFN_FORCESHOWHIDDEN As Long = &H10000000
  155. Public Enum CdlOFNConstants
  156.     CdlOFNReadOnly = OFN_READONLY
  157.     CdlOFNOverwritePrompt = OFN_OVERWRITEPROMPT
  158.     CdlOFNHideReadOnly = OFN_HIDEREADONLY
  159.     CdlOFNNoChangeDir = OFN_NOCHANGEDIR
  160.     CdlOFNHelpButton = OFN_SHOWHELP
  161.     CdlOFNNoValidate = OFN_NOVALIDATE
  162.     CdlOFNAllowMultiSelect = OFN_ALLOWMULTISELECT
  163.     CdlOFNExtensionDifferent = OFN_EXTENSIONDIFFERENT
  164.     CdlOFNPathMustExist = OFN_PATHMUSTEXIST
  165.     CdlOFNFileMustExist = OFN_FILEMUSTEXIST
  166.     CdlOFNCreatePrompt = OFN_CREATEPROMPT
  167.     CdlOFNShareAware = OFN_SHAREAWARE
  168.     CdlOFNNoReadOnlyReturn = OFN_NOREADONLYRETURN
  169.     CdlOFNNoNetworkButton = OFN_NONETWORKBUTTON
  170.     CdlOFNExplorer = OFN_EXPLORER
  171.     CdlOFNNoDereferenceLinks = OFN_NODEREFERENCELINKS
  172.     CdlOFNDontAddToRecent = OFN_DONTADDTORECENT
  173.     CdlOFNForcesShowHidden = OFN_FORCESHOWHIDDEN
  174. End Enum
  175. Private Const OFN_SHAREWARN As Long = &H0
  176. Private Const OFN_SHARENOWARN As Long = &H1
  177. Private Const OFN_SHAREFALLTHROUGH As Long = &H2
  178. Public Enum CdlOFNShareViResultConstants
  179.     CdlOFNShareViResultWarn = OFN_SHAREWARN
  180.     CdlOFNShareViResultNoWarn = OFN_SHARENOWARN
  181.     CdlOFNShareViResultFallThrough = OFN_SHAREFALLTHROUGH
  182. End Enum
  183. Private Const CC_RGBINIT As Long = &H1
  184. Private Const CC_FULLOPEN As Long = &H2
  185. Private Const CC_PREVENTFULLOPEN As Long = &H4
  186. Private Const CC_SHOWHELP As Long = &H8
  187. Private Const CC_ENABLEHOOK As Long = &H10                                      ' Internal use only
  188. Private Const CC_SOLIDCOLOR As Long = &H80
  189. Private Const CC_ANYCOLOR As Long = &H100
  190. Public Enum CdlCCConstants
  191.     CdlCCRGBInit = CC_RGBINIT
  192.     CdlCCFullOpen = CC_FULLOPEN
  193.     CdlCCPreventFullOpen = CC_PREVENTFULLOPEN
  194.     CdlCCHelpButton = CC_SHOWHELP
  195.     CdlCCSolidColor = CC_SOLIDCOLOR
  196.     CdlCCAnyColor = CC_ANYCOLOR
  197. End Enum
  198. Private Const CF_SCREENFONTS As Long = &H1
  199. Private Const CF_PRINTERFONTS As Long = &H2
  200. Private Const CF_SHOWHELP As Long = &H4
  201. Private Const CF_ENABLEHOOK As Long = &H8                                       ' Internal use only
  202. Private Const CF_INITTOLOGFONTSTRUCT As Long = &H40                             ' Internal use only
  203. Private Const CF_EFFECTS As Long = &H100
  204. Private Const CF_APPLY As Long = &H200
  205. Private Const CF_SCRIPTSONLY As Long = &H400
  206. Private Const CF_NOVECTORFONTS As Long = &H800
  207. Private Const CF_LIMITSIZE As Long = &H2000
  208. Private Const CF_FIXEDPITCHONLY As Long = &H4000
  209. Private Const CF_FORCEFONTEXIST As Long = &H10000
  210. Private Const CF_SCALABLEONLY As Long = &H20000
  211. Private Const CF_TTONLY As Long = &H40000
  212. Private Const CF_NOFACESEL As Long = &H80000
  213. Private Const CF_NOSTYLESEL As Long = &H100000
  214. Private Const CF_NOSIZESEL As Long = &H200000
  215. Private Const CF_SELECTSCRIPT As Long = &H400000
  216. Private Const CF_NOSCRIPTSEL As Long = &H800000
  217. Private Const CF_NOVERTFONTS As Long = &H1000000
  218. Public Enum CdlCFConstants
  219.     CdlCFScreenFonts = CF_SCREENFONTS
  220.     CdlCFPrinterFonts = CF_PRINTERFONTS
  221.     CdlCFHelpButton = CF_SHOWHELP
  222.     CdlCFEffects = CF_EFFECTS
  223.     CdlCFApply = CF_APPLY
  224.     CdlCFScriptsOnly = CF_SCRIPTSONLY
  225.     CdlCFNoVectorFonts = CF_NOVECTORFONTS
  226.     CdlCFLimitSize = CF_LIMITSIZE
  227.     CdlCFFixedPitchOnly = CF_FIXEDPITCHONLY
  228.     CdlCFForceFontExist = CF_FORCEFONTEXIST
  229.     CdlCFScalableOnly = CF_SCALABLEONLY
  230.     CdlCFTTOnly = CF_TTONLY
  231.     CdlCFNoFaceSel = CF_NOFACESEL
  232.     CdlCFNoStyleSel = CF_NOSTYLESEL
  233.     CdlCFNoSizeSel = CF_NOSIZESEL
  234.     CdlCFSelectScript = CF_SELECTSCRIPT
  235.     CdlCFNoScriptSel = CF_NOSCRIPTSEL
  236.     CdlCFNoVertFonts = CF_NOVERTFONTS
  237. End Enum
  238. Private Const PD_ALLPAGES As Long = &H0
  239. Private Const PD_SELECTION As Long = &H1
  240. Private Const PD_PAGENUMS As Long = &H2
  241. Private Const PD_NOSELECTION As Long = &H4
  242. Private Const PD_NOPAGENUMS As Long = &H8
  243. Private Const PD_COLLATE As Long = &H10
  244. Private Const PD_PRINTTOFILE As Long = &H20
  245. Private Const PD_PRINTSETUP As Long = &H40                                      ' PRINTDLG only
  246. Private Const PD_NOWARNING As Long = &H80
  247. Private Const PD_RETURNDC As Long = &H100
  248. Private Const PD_RETURNIC As Long = &H200
  249. Private Const PD_RETURNDEFAULT As Long = &H400
  250. Private Const PD_SHOWHELP As Long = &H800                                       ' PRINTDLG only
  251. Private Const PD_ENABLEPRINTHOOK As Long = &H1000                               ' Internal use only
  252. Private Const PD_ENABLESETUPHOOK As Long = &H2000                               ' Internal use only
  253. Private Const PD_USEDEVMODECOPIES As Long = &H40000
  254. Private Const PD_USEDEVMODECOPIESANDCOLLATE As Long = &H40000
  255. Private Const PD_DISABLEPRINTTOFILE As Long = &H80000
  256. Private Const PD_CURRENTPAGE As Long = &H400000                                 ' PRINTDLGEX only
  257. Private Const PD_HIDEPRINTTOFILE As Long = &H100000
  258. Private Const PD_NONETWORKBUTTON As Long = &H200000                             ' PRINTDLG only
  259. Private Const PD_NOCURRENTPAGE As Long = &H800000                               ' PRINTDLGEX only
  260. Public Enum CdlPDConstants
  261.     CdlPDAllPages = PD_ALLPAGES
  262.     CdlPDSelection = PD_SELECTION
  263.     CdlPDPageNums = PD_PAGENUMS
  264.     CdlPDNoSelection = PD_NOSELECTION
  265.     CdlPDNoPageNums = PD_NOPAGENUMS
  266.     CdlPDCollate = PD_COLLATE
  267.     CdlPDPrintToFile = PD_PRINTTOFILE
  268.     CdlPDPrintSetup = PD_PRINTSETUP
  269.     CdlPDNoWarning = PD_NOWARNING
  270.     CdlPDReturnDC = PD_RETURNDC
  271.     CdlPDReturnIC = PD_RETURNIC
  272.     CdlPDReturnDefault = PD_RETURNDEFAULT
  273.     CdlPDHelpButton = PD_SHOWHELP
  274.     CdlPDUseDevModeCopies = PD_USEDEVMODECOPIES
  275.     CdlPDUseDevModeCopiesAndCollate = PD_USEDEVMODECOPIESANDCOLLATE
  276.     CdlPDDisablePrintToFile = PD_DISABLEPRINTTOFILE
  277.     CdlPDCurrentPage = PD_CURRENTPAGE
  278.     CdlPDHidePrintToFile = PD_HIDEPRINTTOFILE
  279.     CdlPDNoNetworkButton = PD_NONETWORKBUTTON
  280.     CdlPDNoCurrentPage = PD_NOCURRENTPAGE
  281. End Enum
  282. Private Const PD_RESULT_CANCEL As Long = &H0
  283. Private Const PD_RESULT_PRINT As Long = &H1
  284. Private Const PD_RESULT_APPLY As Long = &H2
  285. Public Enum CdlPDResultConstants
  286.     CdlPDResultCancel = PD_RESULT_CANCEL
  287.     CdlPDResultPrint = PD_RESULT_PRINT
  288.     CdlPDResultApply = PD_RESULT_APPLY
  289. End Enum
  290. Private Const HELP_CONTEXT As Long = &H1
  291. Private Const HELP_QUIT As Long = &H2
  292. Private Const HELP_INDEX As Long = &H3
  293. Private Const HELP_CONTENTS As Long = &H3
  294. Private Const HELP_HELPONHELP As Long = &H4
  295. Private Const HELP_SETINDEX As Long = &H5
  296. Private Const HELP_SETCONTENTS As Long = &H5
  297. Private Const HELP_CONTEXTPOPUP As Long = &H8
  298. Private Const HELP_FORCEFILE As Long = &H9
  299. Private Const HELP_KEY As Long = &H101
  300. Private Const HELP_COMMAND As Long = &H102
  301. Private Const HELP_PARTIALKEY As Long = &H105
  302. Public Enum CdlHelpConstants
  303.     CdlHelpContext = HELP_CONTEXT
  304.     CdlHelpQuit = HELP_QUIT
  305.     CdlHelpIndex = HELP_INDEX
  306.     CdlHelpContents = HELP_CONTENTS
  307.     CdlHelpHelpOnHelp = HELP_HELPONHELP
  308.     CdlHelpSetIndex = HELP_SETINDEX
  309.     CdlHelpSetContents = HELP_SETCONTENTS
  310.     CdlHelpContextPopup = HELP_CONTEXTPOPUP
  311.     CdlHelpForceFile = HELP_FORCEFILE
  312.     CdlHelpKey = HELP_KEY
  313.     CdlHelpCommandHelp = HELP_COMMAND
  314.     CdlHelpPartialKey = HELP_PARTIALKEY
  315. End Enum
  316. Private Const PSD_DEFAULTMINMARGINS As Long = &H0
  317. Private Const PSD_MINMARGINS As Long = &H1
  318. Private Const PSD_MARGINS As Long = &H2
  319. Private Const PSD_INTHOUSANDTHSOFINCHES As Long = &H4
  320. Private Const PSD_INHUNDREDTHSOFMILLIMETERS As Long = &H8
  321. Private Const PSD_DISABLEMARGINS As Long = &H10
  322. Private Const PSD_DISABLEPRINTER As Long = &H20                                 ' Only for Windows XP/2000
  323. Private Const PSD_NOWARNING As Long = &H80
  324. Private Const PSD_DISABLEORIENTATION As Long = &H100
  325. Private Const PSD_DISABLEPAPER As Long = &H200
  326. Private Const PSD_RETURNDEFAULT As Long = &H400
  327. Private Const PSD_SHOWHELP As Long = &H800
  328. Private Const PSD_ENABLEPAGESETUPHOOK As Long = &H2000                          ' Internal use only
  329. Private Const PSD_DISABLEPAGEPAINTING As Long = &H80000
  330. Private Const PSD_NONETWORKBUTTON As Long = &H200000
  331. Public Enum CdlPSDConstants
  332.     CdlPSDDefaultMinMargins = PSD_DEFAULTMINMARGINS
  333.     CdlPSDMinMargins = PSD_MINMARGINS
  334.     CdlPSDMargins = PSD_MARGINS
  335.     CdlPSDInThousandthsOfInches = PSD_INTHOUSANDTHSOFINCHES
  336.     CdlPSDInHundredthsOfMillimeters = PSD_INHUNDREDTHSOFMILLIMETERS
  337.     CdlPSDDisableMargins = PSD_DISABLEMARGINS
  338.     CdlPSDDisablePrinter = PSD_DISABLEPRINTER
  339.     CdlPSDNoWarning = PSD_NOWARNING
  340.     CdlPSDDisableOrientation = PSD_DISABLEORIENTATION
  341.     CdlPSDDisablePaper = PSD_DISABLEPAPER
  342.     CdlPSDReturnDefault = PSD_RETURNDEFAULT
  343.     CdlPSDHelpButton = PSD_SHOWHELP
  344.     CdlPSDDisablePagePainting = PSD_DISABLEPAGEPAINTING
  345.     CdlPSDNoNetworkButton = PSD_NONETWORKBUTTON
  346. End Enum
  347. Private Const BIF_RETURNONLYFSDIRS As Long = &H1
  348. Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
  349. Private Const BIF_STATUSTEXT As Long = &H4
  350. Private Const BIF_RETURNFSANCESTORS As Long = &H8
  351. Private Const BIF_EDITBOX As Long = &H10
  352. Private Const BIF_VALIDATE As Long = &H20
  353. Private Const BIF_NEWDIALOGSTYLE As Long = &H40
  354. Private Const BIF_BROWSEINCLUDEURLS As Long = &H80
  355. Private Const BIF_USENEWUI As Long = BIF_EDITBOX Or BIF_NEWDIALOGSTYLE
  356. Private Const BIF_UAHINT As Long = &H100
  357. Private Const BIF_NONEWFOLDERBUTTON As Long = &H200
  358. Private Const BIF_NOTRANSLATETARGETS As Long = &H400
  359. Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
  360. Private Const BIF_BROWSEFORPRINTER As Long = &H2000
  361. Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
  362. Private Const BIF_SHAREABLE As Long = &H8000&
  363. Private Const BIF_BROWSEFILEJUNCTIONS As Long = &H10000
  364. Public Enum CdlBIFConstants
  365.     CdlBIFReturnOnlyFSDirs = BIF_RETURNONLYFSDIRS
  366.     CdlBIFDontGoBelowDomain = BIF_DONTGOBELOWDOMAIN
  367.     CdlBIFStatusText = BIF_STATUSTEXT
  368.     CdlBIFReturnFSAncestors = BIF_RETURNFSANCESTORS
  369.     CdlBIFEditBox = BIF_EDITBOX
  370.     CdlBIFValidate = BIF_VALIDATE
  371.     CdlBIFNewDialogStyle = BIF_NEWDIALOGSTYLE
  372.     CdlBIFBrowseIncludeURLs = BIF_BROWSEINCLUDEURLS
  373.     CdlBIFUseNewUI = BIF_USENEWUI
  374.     CdlBIFUAHint = BIF_UAHINT
  375.     CdlBIFNoNewFolderButton = BIF_NONEWFOLDERBUTTON
  376.     CdlBIFNoTranslateTargets = BIF_NOTRANSLATETARGETS
  377.     CdlBIFBrowseForComputer = BIF_BROWSEFORCOMPUTER
  378.     CdlBIFBrowseForPrinter = BIF_BROWSEFORPRINTER
  379.     CdlBIFBrowseIncludeFiles = BIF_BROWSEINCLUDEFILES
  380.     CdlBIFShareable = BIF_SHAREABLE
  381.     CdlBIFBrowseFileJunctions = BIF_BROWSEFILEJUNCTIONS
  382. End Enum
  383. Private Const FR_DOWN As Long = &H1
  384. Private Const FR_WHOLEWORD As Long = &H2
  385. Private Const FR_MATCHCASE As Long = &H4
  386. Private Const FR_FINDNEXT As Long = &H8
  387. Private Const FR_REPLACE As Long = &H10
  388. Private Const FR_REPLACEALL As Long = &H20
  389. Private Const FR_DIALOGTERM As Long = &H40                                      ' Internal use only
  390. Private Const FR_SHOWHELP As Long = &H80
  391. Private Const FR_ENABLEHOOK As Long = &H100                                     ' Internal use only
  392. Private Const FR_NOUPDOWN As Long = &H400
  393. Private Const FR_NOMATCHCASE As Long = &H800
  394. Private Const FR_NOWHOLEWORD As Long = &H1000
  395. Private Const FR_HIDEUPDOWN As Long = &H4000
  396. Private Const FR_HIDEMATCHCASE As Long = &H8000
  397. Private Const FR_HIDEWHOLEWORD As Long = &H10000
  398. Public Enum CdlFRConstants
  399.     CdlFRDown = FR_DOWN
  400.     CdlFRWholeWord = FR_WHOLEWORD
  401.     CdlFRMatchCase = FR_MATCHCASE
  402.     CdlFRFindNext = FR_FINDNEXT
  403.     CdlFRReplace = FR_REPLACE
  404.     CdlFRReplaceAll = FR_REPLACEALL
  405.     CdlFRHelpButton = FR_SHOWHELP
  406.     CdlFRNoUpDown = FR_NOUPDOWN
  407.     CdlFRNoMatchCase = FR_NOMATCHCASE
  408.     CdlFRNoWholeWord = FR_NOWHOLEWORD
  409.     CdlFRHideUpDown = FR_HIDEUPDOWN
  410.     CdlFRHideMatchCase = FR_HIDEMATCHCASE
  411.     CdlFRHideWholeWord = FR_HIDEWHOLEWORD
  412. End Enum
  413. Private Type RECT
  414.     Left As Long
  415.     Top As Long
  416.     Right As Long
  417.     Bottom As Long
  418. End Type
  419. Private Type POINTAPI
  420.     X As Long
  421.     Y As Long
  422. End Type
  423. Private Type OPENFILENAME
  424.     lStructSize As Long
  425.     hWndOwner As Long
  426.     hInstance As Long
  427.     lpstrFilter As Long
  428.     lpstrCustomFilter As Long
  429.     nMaxCustFilter As Long
  430.     nFilterIndex As Long
  431.     lpstrFile As Long
  432.     nMaxFile As Long
  433.     lpstrFileTitle As Long
  434.     nMaxFileTitle As Long
  435.     lpstrInitialDir As Long
  436.     lpstrTitle As Long
  437.     Flags As Long
  438.     nFileOffset As Integer
  439.     nFileExtension As Integer
  440.     lpstrDefExt As Long
  441.     lCustData As Long
  442.     lpfnHook As Long
  443.     lpTemplateName As Long
  444.     pvReserved As Long
  445.     dwReserved As Long
  446.     FlagsEx As Long
  447. End Type
  448. Private Type TCHOOSECOLOR
  449.     lStructSize As Long
  450.     hWndOwner As Long
  451.     hInstance As Long
  452.     RGBResult As Long
  453.     lpCustColors As Long
  454.     Flags As Long
  455.     lCustData As Long
  456.     lpfnHook As Long
  457.     lpTemplateName As Long
  458. End Type
  459. Private Type TCHOOSEFONT
  460.     lStructSize As Long
  461.     hWndOwner As Long
  462.     hDC As Long
  463.     lpLogFont As Long
  464.     iPointSize As Long
  465.     Flags As Long
  466.     RGBColor As Long
  467.     lCustData As Long
  468.     lpfnHook As Long
  469.     lpTemplateName As Long
  470.     hInstance As Long
  471.     lpszStyle As Long
  472.     nFontType As Integer
  473.     nSizeMin As Long
  474.     nSizeMax As Long
  475. End Type
  476. Private Const LF_FACESIZE As Long = 32
  477. Private Const FW_NORMAL As Long = 400
  478. Private Const FW_BOLD As Long = 700
  479. Private Const DEFAULT_QUALITY As Long = 0
  480. Private Type LOGFONT
  481.     LFHeight As Long
  482.     LFWidth As Long
  483.     LFEscapement As Long
  484.     LFOrientation As Long
  485.     LFWeight As Long
  486.     LFItalic As Byte
  487.     LFUnderline As Byte
  488.     LFStrikeOut As Byte
  489.     LFCharset As Byte
  490.     LFOutPrecision As Byte
  491.     LFClipPrecision As Byte
  492.     LFQuality As Byte
  493.     LFPitchAndFamily As Byte
  494.     LFFaceName(0 To ((LF_FACESIZE * 2) - 1)) As Byte
  495. End Type
  496. Private Type PRINTDLG
  497.     lStructSize As Long
  498.     hWndOwner As Long
  499.     hDevMode As Long
  500.     hDevNames As Long
  501.     hDC As Long
  502.     Flags As Long
  503.     nFromPage As Integer
  504.     nToPage As Integer
  505.     nMinPage As Integer
  506.     nMaxPage As Integer
  507.     nCopies As Integer
  508.     hInstanceLo As Integer
  509.     hInstanceHi As Integer
  510.     lCustDataLo As Integer
  511.     lCustDataHi As Integer
  512.     lpfnPrintHookLo As Integer
  513.     lpfnPrintHookHi As Integer
  514.     lpfnSetupHookLo As Integer
  515.     lpfnSetupHookHi As Integer
  516.     lpPrintTemplateNameLo As Integer
  517.     lpPrintTemplateNameHi As Integer
  518.     lpSetupTemplateNameLo As Integer
  519.     lpSetupTemplateNameHi As Integer
  520.     hPrintTemplateLo As Integer
  521.     hPrintTemplateHi As Integer
  522.     hSetupTemplateLo As Integer
  523.     hSetupTemplateHi As Integer
  524. End Type
  525. Private Type PRINTPAGERANGE
  526.     nFromPage As Long
  527.     nToPage As Long
  528. End Type
  529. Private Type PRINTDLGEX
  530.     lStructSize As Long
  531.     hWndOwner As Long
  532.     hDevMode As Long
  533.     hDevNames As Long
  534.     hDC As Long
  535.     Flags As Long
  536.     Flags2 As Long
  537.     ExclusionFlags As Long
  538.     nPageRanges As Long
  539.     nMaxPageRanges As Long
  540.     lpPageRanges As Long
  541.     nMinPage As Long
  542.     nMaxPage As Long
  543.     nCopies As Long
  544.     hInstance As Long
  545.     lpPrintTemplateName As Long
  546.     lpCallback As Long
  547.     nPropertyPages As Long
  548.     lphPropertyPages As Long
  549.     nStartPage As Long
  550.     dwResultAction As Long
  551. End Type
  552. Private Type PAGESETUPDLG
  553.     lStructSize As Long
  554.     hWndOwner As Long
  555.     hDevMode As Long
  556.     hDevNames As Long
  557.     Flags As Long
  558.     PTPaperSize As POINTAPI
  559.     RCMinMargin As RECT
  560.     RCMargin As RECT
  561.     hInstance As Long
  562.     lCustData As Long
  563.     lpfnPageSetupHook As Long
  564.     lpfnPagePaintHook As Long
  565.     lpPageSetupTemplateName As Long
  566.     hPageSetupTemplate As Long
  567. End Type
  568. Private Const CCHDEVNAMESEXTRA As Long = 100
  569. Private Const DN_DEFAULTPRN As Long = 1
  570. Private Type DEVNAMES
  571.     wDriverOffset As Integer
  572.     wDeviceOffset As Integer
  573.     wOutputOffset As Integer
  574.     wDefault As Integer
  575.     wExtra(0 To ((CCHDEVNAMESEXTRA * 2) - 1)) As Byte
  576. End Type
  577. Private Const CCHDEVICENAME As Long = 32
  578. Private Const CCHFORMNAME As Long = 32
  579. Private Const DM_ORIENTATION As Long = &H1
  580. Private Const DM_PAPERSIZE As Long = &H2
  581. Private Const DM_COPIES As Long = &H100
  582. Private Const DM_DEFAULTSOURCE As Long = &H200
  583. Private Const DM_PRINTQUALITY As Long = &H400
  584. Private Const DM_COLOR As Long = &H800
  585. Private Const DM_DUPLEX As Long = &H1000
  586. Private Const DM_COLLATE As Long = &H8000&
  587. Private Type DEVMODE
  588.     DMDeviceName(0 To ((CCHDEVICENAME * 2) - 1)) As Byte
  589.     DMSpecVersion As Integer
  590.     DMDriverVersion As Integer
  591.     DMSize As Integer
  592.     DMDriverExtra As Integer
  593.     DMFields As Long
  594.     DMOrientation As Integer
  595.     DMPaperSize As Integer
  596.     DMPaperLength As Integer
  597.     DMPaperWidth As Integer
  598.     DMScale As Integer
  599.     DMCopies As Integer
  600.     DMDefaultSource As Integer
  601.     DMPrintQuality As Integer
  602.     DMColor As Integer
  603.     DMDuplex As Integer
  604.     DMYResolution As Integer
  605.     DMTTOption As Integer
  606.     DMCollate As Integer
  607.     DMFormName(0 To ((CCHFORMNAME * 2) - 1)) As Byte
  608.     DMLogPixels As Integer
  609.     DMBitsPerPel As Long
  610.     DMPelsWidth As Long
  611.     DMPelsHeight As Long
  612.     DMDisplayFlags As Long
  613.     DMDisplayFrequency As Long
  614.     DMICMMethod As Long
  615.     DMICMIntent As Long
  616.     DMMediaType As Long
  617.     DMDitherType As Long
  618.     DMReserved1 As Long
  619.     DMReserved2 As Long
  620.     DMPanningWidth As Long
  621.     DMPanningHeight As Long
  622. End Type
  623. Private Type BROWSEINFO
  624.     hWndOwner As Long
  625.     pIDLRoot As Long
  626.     pszDisplayName As Long
  627.     lpszTitle As Long
  628.     ulFlags As Long
  629.     lpfnCallback As Long
  630.     lParam As Long
  631.     iImage As Long
  632. End Type
  633. Private Type FINDREPLACE
  634.     lStructSize As Long
  635.     hWndOwner As Long
  636.     hInstance As Long
  637.     Flags As Long
  638.     lpstrFindWhat As Long
  639.     lpstrReplaceWith As Long
  640.     wFindWhatLen As Integer
  641.     wReplaceWithLen As Integer
  642.     lCustData As Long
  643.     lpfnHook As Long
  644.     lpTemplateName As Long
  645. End Type
  646. Private Type NMHDR
  647.     hWndFrom As Long
  648.     IDFrom As Long
  649.     Code As Long
  650. End Type
  651. Private Type NMOFNOTIFY
  652.     hdr As NMHDR
  653.     lpOFN As Long
  654.     lpszFileShareVi As Long
  655. End Type
  656. Public Event InitDialog(ByVal Action As Integer, ByVal hDlg As Long)
  657. Public Event Help(ByRef Handled As Boolean, ByVal Action As Integer, ByVal hDlg As Long)
  658. Public Event FileShareViolation(ByVal FileName As String, ByRef Result As CdlOFNShareViResultConstants, ByVal hDlg As Long)
  659. Public Event FileValidate(ByVal FileName As String, ByVal FileTitle As String, ByVal FileOffset As Integer, ByRef Cancel As Boolean, ByVal hDlg As Long)
  660. Public Event ColorValidate(ByRef RGBColor As Long, ByRef Cancel As Boolean, ByVal hDlg As Long)
  661. 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)
  662. Public Event FolderBrowserValidateFailed(ByVal Text As String, ByRef Cancel As Boolean, ByVal hDlg As Long)
  663. Public Event FindNext()
  664. Public Event Replace()
  665. Public Event ReplaceAll()
  666. Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal hMem As Long)
  667. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
  668. Private Declare Function CommDlgExtendedError Lib "comdlg32" () As Long
  669. Private Declare Function GetOpenFileName Lib "comdlg32" Alias "GetOpenFileNameW" (ByRef lpOpenFileName As OPENFILENAME) As Long
  670. Private Declare Function GetSaveFileName Lib "comdlg32" Alias "GetSaveFileNameW" (ByRef lpOpenFileName As OPENFILENAME) As Long
  671. Private Declare Function ChooseColor Lib "comdlg32" Alias "ChooseColorW" (ByRef lpChooseColor As TCHOOSECOLOR) As Long
  672. Private Declare Function ChooseFont Lib "comdlg32" Alias "ChooseFontW" (ByRef lpChooseFont As TCHOOSEFONT) As Long
  673. 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
  674. Private Declare Function GetActiveWindow Lib "user32" () As Long
  675. 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
  676. Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
  677. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  678. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  679. Private Declare Function GetFocus Lib "user32" () As Long
  680. Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
  681. Private Declare Function SHBrowseForFolder Lib "shell32" Alias "SHBrowseForFolderW" (ByRef lpBrowseInfo As BROWSEINFO) As Long
  682. 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
  683. Private Declare Function ILCreateFromPath Lib "shell32" (ByVal lpszPath As Long) As Long
  684. Private Declare Function ILCreateFromPath_W2K Lib "shell32" Alias "#157" (ByVal lpszPath As Long) As Long
  685. Private Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListW" (ByVal lpIDList As Long, ByVal lpBuffer As Long) As Long
  686. Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageW" (ByVal lpString As Long) As Long
  687. 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
  688. 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
  689. 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
  690. Private Declare Function PrintDialog Lib "comdlg32" Alias "PrintDlgW" (ByRef lpPrintDlg As PRINTDLG) As Long
  691. Private Declare Function PrintDialogEx Lib "comdlg32" Alias "PrintDlgExW" (ByRef lpPrintDlgEx As PRINTDLGEX) As Long
  692. Private Declare Function PageSetupDialog Lib "comdlg32" Alias "PageSetupDlgW" (ByRef lpPageSetupDlg As PAGESETUPDLG) As Long
  693. Private Declare Function GetDefaultPrinter Lib "winspool.drv" Alias "GetDefaultPrinterW" (ByVal lpszPrinterName As Long, ByRef cch As Long) As Long
  694. Private Declare Function SetDefaultPrinter Lib "winspool.drv" Alias "SetDefaultPrinterW" (ByVal lpszPrinterName As Long) As Long
  695. Private Declare Function FindText Lib "comdlg32" Alias "FindTextW" (ByRef lpFindReplace As FINDREPLACE) As Long
  696. Private Declare Function ReplaceText Lib "comdlg32" Alias "ReplaceTextW" (ByRef lpFindReplace As FINDREPLACE) As Long
  697. Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
  698. Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
  699. Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  700. Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
  701. Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
  702. Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
  703. Private Const HELPMSGSTRING As String = "commdlg_help"
  704. Private Const SHAREVISTRING As String = "commdlg_ShareViolation"
  705. Private Const FILEOKSTRING As String = "commdlg_FileNameOK"
  706. Private Const COLOROKSTRING As String = "commdlg_ColorOK"
  707. Private Const SETRGBSTRING As String = "commdlg_SetRGBColor"
  708. Private Const FINDMSGSTRING As String = "commdlg_FindReplace"
  709. Private Const WM_INITDIALOG As Long = &H110
  710. Private Const WM_COMMAND As Long = &H111
  711. Private Const WM_NOTIFY As Long = &H4E
  712. Private Const WM_USER As Long = &H400
  713. Private Const BN_CLICKED As Long = 0
  714. Private Const DWL_MSGRESULT As Long = 0
  715. Private Const GMEM_MOVEABLE As Long = &H2
  716. Private Const GMEM_ZEROINIT As Long = &H40
  717. Private Const MAXINT_2 As Integer = 32767
  718. Private Const MAX_PATH As Long = 260
  719. Private Const S_OK As Long = &H0
  720. Implements ISubclass
  721. Private CommonDialogHelpMsg As Long
  722. Private CommonDialogShareViMsg As Long
  723. Private CommonDialogFileOKMsg As Long
  724. Private CommonDialogColorOKMsg As Long
  725. Private CommonDialogSetRGBMsg As Long
  726. Private CommonDialogFindMsg As Long
  727. Private CommonDialogFR As FINDREPLACE
  728. Private CommonDialogFRDialogHandle As Long
  729. Private CommonDialogFRBufferFindWhat As String
  730. Private CommonDialogFRBufferReplaceWith As String
  731. Private CommonDialogDMFieldsExclusion As Long
  732. Private PropCancelError As Boolean
  733. Private PropHookEvents As Boolean
  734. Private PropTag As String
  735. Private PropDC As Long
  736. Private PropFlags As Long
  737. Private PropDialogTitle As String
  738. Private PropMaxFileSize As Long
  739. Private PropFileName As String, PropFileTitle As String
  740. Private PropFileOffset As Integer
  741. Private PropFilter As String, PropFilterIndex As Long
  742. Private PropInitDir As String
  743. Private PropDefaultExt As String
  744. Private PropColor As Long
  745. Private PropFontName As String, PropFontSize As Single, PropFontBold As Boolean, PropFontItalic As Boolean, PropFontStrikethru As Boolean, PropFontUnderline As Boolean, PropFontCharset As Integer
  746. Private PropMin As Long, PropMax As Long
  747. Private PropFromPage As Long, PropToPage As Long
  748. Private PropOrientation As CdlPRORConstants
  749. Private PropPaperSize As CdlPRPSConstants
  750. Private PropCopies As Integer
  751. Private PropPaperBin As CdlPRBNConstants
  752. Private PropPrintQuality As CdlPRPQConstants
  753. Private PropColorMode As CdlPRCMConstants
  754. Private PropDuplex As CdlPRDPConstants
  755. Private PropPrinterDefault As Boolean, PropPrinterDefaultInit As Boolean
  756. Private PropPrinterDriver As String, PropPrinterName As String, PropPrinterPort As String
  757. Private PropHelpFile As String
  758. Private PropHelpCommand As CdlHelpConstants
  759. Private PropHelpContext As Long
  760. Private PropHelpKey As String
  761. Private PropPageLeftMargin As Long, PropPageTopMargin As Long, PropPageRightMargin As Long, PropPageBottomMargin As Long
  762. Private PropPageLeftMinMargin As Long, PropPageTopMinMargin As Long, PropPageRightMinMargin As Long, PropPageBottomMinMargin As Long
  763. Private PropRootFolder As Variant
  764. Private PropFindWhat As String
  765. Private PropReplaceWith As String

  766. Private Sub Class_Initialize()
  767.     Const LOCALE_IMEASURE As Long = &HD, LOCALE_RETURN_NUMBER As Long = &H20000000
  768.     Dim LocaleMeasure As Long
  769.     GetLocaleInfo 0, LOCALE_IMEASURE Or LOCALE_RETURN_NUMBER, VarPtr(LocaleMeasure), LenB(LocaleMeasure)
  770.     CommonDialogDMFieldsExclusion = DM_ORIENTATION Or DM_PAPERSIZE Or DM_DEFAULTSOURCE Or DM_PRINTQUALITY Or DM_COLOR Or DM_DUPLEX
  771.     PropMaxFileSize = MAX_PATH
  772.     PropFontSize = 8
  773.     PropOrientation = CdlPRORPortrait
  774.     PropPaperSize = IIf(LocaleMeasure = 0, CdlPRPSA4, CdlPRPSLetter)
  775.     PropCopies = 1
  776.     PropPaperBin = CdlPRBNAuto
  777.     PropPrintQuality = CdlPRPQHigh
  778.     PropColorMode = CdlPRCMColor
  779.     PropDuplex = CdlPRDPSimplex
  780.     PropPrinterDefault = True
  781.     PropPrinterDefaultInit = True
  782. End Sub

  783. Private Sub Class_Terminate()
  784.     If PropDC <> 0 Then DeleteObject PropDC
  785.     If CommonDialogFRDialogHandle <> 0 Then
  786.         If IsWindow(CommonDialogFRDialogHandle) = 0 Then
  787.             Call ComCtlsCdlFRReleaseHook(CommonDialogFRDialogHandle)
  788.         Else
  789.             Const WM_CLOSE As Long = &H10
  790.             SendMessage CommonDialogFRDialogHandle, WM_CLOSE, 0, ByVal 0&
  791.             DoEvents
  792.         End If
  793.     End If
  794. End Sub

  795. Public Property Get Object() As Object
  796. Set Object = Me
  797. End Property

  798. Public Property Get CancelError() As Boolean
  799.     CancelError = PropCancelError
  800. End Property

  801. Public Property Let CancelError(ByVal Value As Boolean)
  802.     PropCancelError = Value
  803. End Property

  804. Public Property Get HookEvents() As Boolean
  805.     HookEvents = PropHookEvents
  806. End Property

  807. Public Property Let HookEvents(ByVal Value As Boolean)
  808.     PropHookEvents = Value
  809. End Property

  810. Public Property Get Tag() As String
  811.     Tag = PropTag
  812. End Property

  813. Public Property Let Tag(ByVal Value As String)
  814.     PropTag = Value
  815. End Property

  816. Public Property Get hDC() As Long
  817.     hDC = PropDC
  818. End Property

  819. Public Property Let hDC(ByVal Value As Long)
  820.     ERR.Raise Number:=383, Description:="Property is read-only"
  821. End Property

  822. Public Property Get Flags() As Long
  823.     Flags = PropFlags
  824. End Property

  825. Public Property Let Flags(ByVal Value As Long)
  826.     PropFlags = Value
  827. End Property

  828. Public Property Get DialogTitle() As String
  829.     DialogTitle = PropDialogTitle
  830. End Property

  831. Public Property Let DialogTitle(ByVal Value As String)
  832.     PropDialogTitle = Value
  833. End Property

  834. Public Property Get MaxFileSize() As Long
  835.     MaxFileSize = PropMaxFileSize
  836. End Property

  837. Public Property Let MaxFileSize(ByVal Value As Long)
  838.     If Value < 1 Then ERR.Raise 380
  839.     PropMaxFileSize = Value
  840. End Property

  841. Public Property Get FileName() As String
  842.     FileName = PropFileName
  843. End Property

  844. Public Property Let FileName(ByVal Value As String)
  845.     PropFileName = Value
  846. End Property

  847. Public Property Get FileTitle() As String
  848.     FileTitle = PropFileTitle
  849. End Property

  850. Public Property Let FileTitle(ByVal Value As String)
  851.     ERR.Raise Number:=383, Description:="Property is read-only"
  852. End Property

  853. Public Property Get FileOffset() As Integer
  854.     FileOffset = PropFileOffset
  855. End Property

  856. Public Property Let FileOffset(ByVal Value As Integer)
  857.     ERR.Raise Number:=383, Description:="Property is read-only"
  858. End Property

  859. Public Property Get Filter() As String
  860.     Filter = PropFilter
  861. End Property

  862. Public Property Let Filter(ByVal Value As String)
  863.     PropFilter = Value
  864. End Property

  865. Public Property Get FilterIndex() As Long
  866.     FilterIndex = PropFilterIndex
  867. End Property

  868. Public Property Let FilterIndex(ByVal Value As Long)
  869.     If Value < 0 Then ERR.Raise 380
  870.     PropFilterIndex = Value
  871. End Property

  872. Public Property Get InitDir() As String
  873.     InitDir = PropInitDir
  874. End Property

  875. Public Property Let InitDir(ByVal Value As String)
  876.     PropInitDir = Value
  877. End Property

  878. Public Property Get DefaultExt() As String
  879.     DefaultExt = PropDefaultExt
  880. End Property

  881. Public Property Let DefaultExt(ByVal Value As String)
  882.     PropDefaultExt = Value
  883. End Property

  884. Public Property Get Color() As Long
  885.     Color = PropColor
  886. End Property

  887. Public Property Let Color(ByVal Value As Long)
  888.     PropColor = Value
  889. End Property

  890. Public Property Get FontName() As String
  891.     FontName = PropFontName
  892. End Property

  893. Public Property Let FontName(ByVal Value As String)
  894.     PropFontName = Value
  895. End Property

  896. Public Property Get FontSize() As Single
  897.     FontSize = PropFontSize
  898. End Property

  899. Public Property Let FontSize(ByVal Value As Single)
  900.     PropFontSize = Value
  901. End Property

  902. Public Property Get FontBold() As Boolean
  903.     FontBold = PropFontBold
  904. End Property

  905. Public Property Let FontBold(ByVal Value As Boolean)
  906.     PropFontBold = Value
  907. End Property

  908. Public Property Get FontItalic() As Boolean
  909.     FontItalic = PropFontItalic
  910. End Property

  911. Public Property Let FontItalic(ByVal Value As Boolean)
  912.     PropFontItalic = Value
  913. End Property

  914. Public Property Get FontStrikethru() As Boolean
  915.     FontStrikethru = PropFontStrikethru
  916. End Property

  917. Public Property Let FontStrikethru(ByVal Value As Boolean)
  918.     PropFontStrikethru = Value
  919. End Property

  920. Public Property Get FontUnderline() As Boolean
  921.     FontUnderline = PropFontUnderline
  922. End Property

  923. Public Property Let FontUnderline(ByVal Value As Boolean)
  924.     PropFontUnderline = Value
  925. End Property

  926. Public Property Get FontCharset() As Integer
  927.     FontCharset = PropFontCharset
  928. End Property

  929. Public Property Let FontCharset(ByVal Value As Integer)
  930.     PropFontCharset = Value
  931. End Property

  932. Public Property Get Min() As Long
  933.     Min = PropMin
  934. End Property

  935. Public Property Let Min(ByVal Value As Long)
  936.     If Value < 0 Then ERR.Raise 380
  937.     PropMin = Value
  938. End Property

  939. Public Property Get Max() As Long
  940.     Max = PropMax
  941. End Property

  942. Public Property Let Max(ByVal Value As Long)
  943.     If Value < 0 Then ERR.Raise 380
  944.     PropMax = Value
  945. End Property

  946. Public Property Get FromPage() As Long
  947.     FromPage = PropFromPage
  948. End Property

  949. Public Property Let FromPage(ByVal Value As Long)
  950.     If Value < 0 Then ERR.Raise 380
  951.     PropFromPage = Value
  952. End Property

  953. Public Property Get ToPage() As Long
  954.     ToPage = PropToPage
  955. End Property

  956. Public Property Let ToPage(ByVal Value As Long)
  957.     If Value < 0 Then ERR.Raise 380
  958.     PropToPage = Value
  959. End Property

  960. Public Property Get Orientation() As CdlPRORConstants
  961.     Orientation = PropOrientation
  962. End Property

  963. Public Property Let Orientation(ByVal Value As CdlPRORConstants)
  964.     Select Case Value
  965.     Case CdlPRORPortrait, CdlPRORLandscape
  966.         PropOrientation = Value
  967.     Case Else
  968.         ERR.Raise 380
  969.     End Select
  970.     If (CommonDialogDMFieldsExclusion And DM_ORIENTATION) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_ORIENTATION
  971. End Property

  972. Public Property Get PaperSize() As CdlPRPSConstants
  973.     PaperSize = PropPaperSize
  974. End Property

  975. Public Property Let PaperSize(ByVal Value As CdlPRPSConstants)
  976.     Select Case Value
  977.     Case 1 To MAXINT_2
  978.         PropPaperSize = Value
  979.     Case Else
  980.         ERR.Raise 380
  981.     End Select
  982.     If (CommonDialogDMFieldsExclusion And DM_PAPERSIZE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_PAPERSIZE
  983. End Property

  984. Public Property Get Copies() As Integer
  985.     Copies = PropCopies
  986. End Property

  987. Public Property Let Copies(ByVal Value As Integer)
  988.     If Value < 1 Then ERR.Raise 380
  989.     PropCopies = Value
  990. End Property

  991. Public Property Get PaperBin() As CdlPRBNConstants
  992.     PaperBin = PropPaperBin
  993. End Property

  994. Public Property Let PaperBin(ByVal Value As CdlPRBNConstants)
  995.     Select Case Value
  996.     Case 1 To MAXINT_2
  997.         PropPaperBin = Value
  998.     Case Else
  999.         ERR.Raise 380
  1000.     End Select
  1001.     If (CommonDialogDMFieldsExclusion And DM_DEFAULTSOURCE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_DEFAULTSOURCE
  1002. End Property

  1003. Public Property Get PrintQuality() As CdlPRPQConstants
  1004.     PrintQuality = PropPrintQuality
  1005. End Property

  1006. Public Property Let PrintQuality(ByVal Value As CdlPRPQConstants)
  1007.     Select Case Value
  1008.     Case CdlPRPQHigh, CdlPRPQMedium, CdlPRPQLow, CdlPRPQDraft, 0 To MAXINT_2
  1009.         PropPrintQuality = Value
  1010.     Case Else
  1011.         ERR.Raise 380
  1012.     End Select
  1013.     If (CommonDialogDMFieldsExclusion And DM_PRINTQUALITY) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_PRINTQUALITY
  1014. End Property

  1015. Public Property Get ColorMode() As CdlPRCMConstants
  1016.     ColorMode = PropColorMode
  1017. End Property

  1018. Public Property Let ColorMode(ByVal Value As CdlPRCMConstants)
  1019.     Select Case Value
  1020.     Case CdlPRCMMonochrome, CdlPRCMColor
  1021.         PropColorMode = Value
  1022.     Case Else
  1023.         ERR.Raise 380
  1024.     End Select
  1025.     If (CommonDialogDMFieldsExclusion And DM_COLOR) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_COLOR
  1026. End Property

  1027. Public Property Get Duplex() As CdlPRDPConstants
  1028.     Duplex = PropDuplex
  1029. End Property

  1030. Public Property Let Duplex(ByVal Value As CdlPRDPConstants)
  1031.     Select Case Value
  1032.     Case CdlPRDPSimplex, CdlPRDPHorizontal, CdlPRDPVertical
  1033.         PropDuplex = Value
  1034.     Case Else
  1035.         ERR.Raise 380
  1036.     End Select
  1037.     If (CommonDialogDMFieldsExclusion And DM_DUPLEX) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_DUPLEX
  1038. End Property

  1039. Public Property Get PrinterDefault() As Boolean
  1040.     PrinterDefault = PropPrinterDefault
  1041. End Property

  1042. Public Property Let PrinterDefault(ByVal Value As Boolean)
  1043.     PropPrinterDefault = Value
  1044. End Property

  1045. Public Property Get PrinterDefaultInit() As Boolean
  1046.     PrinterDefaultInit = PropPrinterDefaultInit
  1047. End Property

  1048. Public Property Let PrinterDefaultInit(ByVal Value As Boolean)
  1049.     PropPrinterDefaultInit = Value
  1050. End Property

  1051. Public Property Get PrinterDriver() As String
  1052.     PrinterDriver = PropPrinterDriver
  1053. End Property

  1054. Public Property Let PrinterDriver(ByVal Value As String)
  1055.     PropPrinterDriver = Value
  1056. End Property

  1057. Public Property Get PrinterName() As String
  1058.     PrinterName = PropPrinterName
  1059. End Property

  1060. Public Property Let PrinterName(ByVal Value As String)
  1061.     PropPrinterName = Value
  1062. End Property

  1063. Public Property Get PrinterPort() As String
  1064.     PrinterPort = PropPrinterPort
  1065. End Property

  1066. Public Property Let PrinterPort(ByVal Value As String)
  1067.     PropPrinterPort = Value
  1068. End Property

  1069. Public Property Get HelpFile() As String
  1070.     HelpFile = PropHelpFile
  1071. End Property

  1072. Public Property Let HelpFile(ByVal Value As String)
  1073.     PropHelpFile = Value
  1074. End Property

  1075. Public Property Get HelpCommand() As CdlHelpConstants
  1076.     HelpCommand = PropHelpCommand
  1077. End Property

  1078. Public Property Let HelpCommand(ByVal Value As CdlHelpConstants)
  1079.     Select Case Value
  1080.     Case 0, CdlHelpContext, CdlHelpQuit, CdlHelpIndex, CdlHelpContents, CdlHelpHelpOnHelp, CdlHelpSetIndex, CdlHelpSetContents, CdlHelpContextPopup, CdlHelpForceFile, CdlHelpKey, CdlHelpCommandHelp, CdlHelpPartialKey
  1081.         PropHelpCommand = Value
  1082.     Case Else
  1083.         ERR.Raise 380
  1084.     End Select
  1085. End Property

  1086. Public Property Get HelpContext() As Long
  1087.     HelpContext = PropHelpContext
  1088. End Property

  1089. Public Property Let HelpContext(ByVal Value As Long)
  1090.     PropHelpContext = Value
  1091. End Property

  1092. Public Property Get HelpKey() As String
  1093.     HelpKey = PropHelpKey
  1094. End Property

  1095. Public Property Let HelpKey(ByVal Value As String)
  1096.     PropHelpKey = Value
  1097. End Property

  1098. Public Property Get PageLeftMargin() As Long
  1099.     PageLeftMargin = PropPageLeftMargin
  1100. End Property

  1101. Public Property Let PageLeftMargin(ByVal Value As Long)
  1102.     If Value < 0 Then ERR.Raise 380
  1103.     PropPageLeftMargin = Value
  1104. End Property

  1105. Public Property Get PageTopMargin() As Long
  1106.     PageTopMargin = PropPageTopMargin
  1107. End Property

  1108. Public Property Let PageTopMargin(ByVal Value As Long)
  1109.     If Value < 0 Then ERR.Raise 380
  1110.     PropPageTopMargin = Value
  1111. End Property

  1112. Public Property Get PageRightMargin() As Long
  1113.     PageRightMargin = PropPageRightMargin
  1114. End Property

  1115. Public Property Let PageRightMargin(ByVal Value As Long)
  1116.     If Value < 0 Then ERR.Raise 380
  1117.     PropPageRightMargin = Value
  1118. End Property

  1119. Public Property Get PageBottomMargin() As Long
  1120.     PageBottomMargin = PropPageBottomMargin
  1121. End Property

  1122. Public Property Let PageBottomMargin(ByVal Value As Long)
  1123.     If Value < 0 Then ERR.Raise 380
  1124.     PropPageBottomMargin = Value
  1125. End Property

  1126. Public Property Get PageLeftMinMargin() As Long
  1127.     PageLeftMinMargin = PropPageLeftMinMargin
  1128. End Property

  1129. Public Property Let PageLeftMinMargin(ByVal Value As Long)
  1130.     If Value < 0 Then ERR.Raise 380
  1131.     PropPageLeftMinMargin = Value
  1132. End Property

  1133. Public Property Get PageTopMinMargin() As Long
  1134.     PageTopMinMargin = PropPageTopMinMargin
  1135. End Property

  1136. Public Property Let PageTopMinMargin(ByVal Value As Long)
  1137.     If Value < 0 Then ERR.Raise 380
  1138.     PropPageTopMinMargin = Value
  1139. End Property

  1140. Public Property Get PageRightMinMargin() As Long
  1141.     PageRightMinMargin = PropPageRightMinMargin
  1142. End Property

  1143. Public Property Let PageRightMinMargin(ByVal Value As Long)
  1144.     If Value < 0 Then ERR.Raise 380
  1145.     PropPageRightMinMargin = Value
  1146. End Property

  1147. Public Property Get PageBottomMinMargin() As Long
  1148.     PageBottomMinMargin = PropPageBottomMinMargin
  1149. End Property

  1150. Public Property Let PageBottomMinMargin(ByVal Value As Long)
  1151.     If Value < 0 Then ERR.Raise 380
  1152.     PropPageBottomMinMargin = Value
  1153. End Property

  1154. Public Property Get RootFolder() As Variant
  1155.     RootFolder = PropRootFolder
  1156. End Property

  1157. Public Property Let RootFolder(ByVal Value As Variant)
  1158.     Select Case VarType(Value)
  1159.     Case vbEmpty, vbLong, vbInteger, vbByte, vbString, vbDouble, vbSingle
  1160.         PropRootFolder = Value
  1161.     Case Else
  1162.         ERR.Raise 380
  1163.     End Select
  1164. End Property

  1165. Public Property Get FindWhat() As String
  1166.     FindWhat = PropFindWhat
  1167. End Property

  1168. Public Property Let FindWhat(ByVal Value As String)
  1169.     PropFindWhat = Value
  1170. End Property

  1171. Public Property Get ReplaceWith() As String
  1172.     ReplaceWith = PropReplaceWith
  1173. End Property

  1174. Public Property Let ReplaceWith(ByVal Value As String)
  1175.     PropReplaceWith = Value
  1176. End Property

  1177. Public Property Get Action() As Integer
  1178.     ERR.Raise Number:=394, Description:="Property is write-only"
  1179. End Property

  1180. Public Property Let Action(ByVal Value As Integer)
  1181.     Select Case Value
  1182.     Case 1
  1183.         Me.ShowOpen
  1184.     Case 2
  1185.         Me.ShowSave
  1186.     Case 3
  1187.         Me.ShowColor
  1188.     Case 4
  1189.         Me.ShowFont
  1190.     Case 5
  1191.         Me.ShowPrinter
  1192.     Case 6
  1193.         Me.ShowHelp
  1194.     Case 7
  1195.         Me.ShowPageSetup
  1196.     Case 8
  1197.         Me.ShowFolderBrowser
  1198.     Case 9
  1199.         Me.ShowFind
  1200.     Case 10
  1201.         Me.ShowReplace
  1202.     Case Else
  1203.         ERR.Raise 380
  1204.     End Select
  1205. End Property

  1206. Public Function ShowOpen() As Boolean
  1207.     Dim Buffer As String, Filter As String
  1208.     Buffer = String(PropMaxFileSize, vbNullChar)
  1209.     Dim OFN As OPENFILENAME
  1210.     With OFN
  1211.         .lStructSize = LenB(OFN)
  1212.         .hWndOwner = GetOwnerWindow()
  1213.         .hInstance = App.hInstance
  1214.         Filter = ProperFilter(PropFilter)
  1215.         .lpstrFilter = StrPtr(Filter)
  1216.         .nFilterIndex = PropFilterIndex
  1217.         If Not PropFileName = vbNullString Then Mid$(Buffer, 1, Len(PropFileName)) = PropFileName
  1218.         .lpstrFile = StrPtr(Buffer)
  1219.         .nMaxFile = Len(Buffer)
  1220.         .lpstrInitialDir = StrPtr(PropInitDir)
  1221.         .lpstrTitle = StrPtr(PropDialogTitle)
  1222.         If PropHookEvents = False Then
  1223.             .Flags = PropFlags
  1224.         Else
  1225.             .Flags = (OFN_ENABLEHOOK Or OFN_ENABLESIZING) Or PropFlags
  1226.             If (PropFlags And CdlOFNExplorer) = CdlOFNExplorer Then
  1227.                 .lpfnHook = ProcPtr(AddressOf ComCtlsCdlOFN1CallbackProc)
  1228.             Else
  1229.                 .lpfnHook = ProcPtr(AddressOf ComCtlsCdlOFN1CallbackProcOldStyle)
  1230.             End If
  1231.             Dim This As ISubclass
  1232.             Set This = Me
  1233.             .lCustData = ObjPtr(This)
  1234.         End If
  1235.     End With
  1236.     Dim RetVal As Long
  1237.     If (PropFlags And CdlOFNHelpButton) = CdlOFNHelpButton Then
  1238.         If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
  1239.         Call ComCtlsSetSubclass(OFN.hWndOwner, Me, 1, HELPMSGSTRING & "_1")
  1240.         RetVal = GetOpenFileName(OFN)
  1241.         Call ComCtlsRemoveSubclass(OFN.hWndOwner, HELPMSGSTRING & "_1")
  1242.     Else
  1243.         RetVal = GetOpenFileName(OFN)
  1244.     End If
  1245.     If RetVal <> 0 Then
  1246.         If (OFN.Flags And (OFN_ENABLEHOOK Or OFN_ENABLESIZING)) = 0 Then
  1247.             PropFlags = OFN.Flags
  1248.         Else
  1249.             PropFlags = OFN.Flags And Not (OFN_ENABLEHOOK Or OFN_ENABLESIZING)
  1250.         End If
  1251.         If OFN.nFileOffset > 0 Then
  1252.             If Mid$(Buffer, OFN.nFileOffset, 1) = vbNullChar Then
  1253.                 PropFileName = Left$(Buffer, InStr(Buffer & vbNullChar & vbNullChar, vbNullChar & vbNullChar) - 1)
  1254.                 PropFileTitle = vbNullString
  1255.             Else
  1256.                 PropFileName = Left$(Buffer, InStr(Buffer & vbNullChar, vbNullChar) - 1)
  1257.                 PropFileTitle = Mid$(PropFileName, OFN.nFileOffset + 1)
  1258.             End If
  1259.         End If
  1260.         PropFilterIndex = OFN.nFilterIndex
  1261.         PropFileOffset = OFN.nFileOffset
  1262.         ShowOpen = True
  1263.     Else
  1264.         Dim ErrVal As Long
  1265.         ErrVal = CommDlgExtendedError()
  1266.         Select Case ErrVal
  1267.         Case FNERR_BUFFERTOOSMALL
  1268.             ERR.Raise Number:=CdlBufferTooSmall, Description:="The buffer at which the member LpstrFile points is too small."
  1269.         Case FNERR_INVALIDFILENAME
  1270.             ERR.Raise Number:=CdlInvalidFileName, Description:="File name is invalid."
  1271.         Case FNERR_SUBCLASSFAILURE
  1272.             ERR.Raise Number:=CdlSubclassFailure, Description:="An attempt to subclass a listbox failed due to insufficient memory."
  1273.         Case 0
  1274.             If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
  1275.         Case Else
  1276.             ERR.Raise Number:=ErrVal, Description:="Unexpected error."
  1277.         End Select
  1278.     End If
  1279. End Function

  1280. Public Function ShowSave() As Boolean
  1281.     Dim Buffer As String, Filter As String, DefaultExt As String
  1282.     Buffer = String(PropMaxFileSize, vbNullChar)
  1283.     Dim OFN As OPENFILENAME
  1284.     With OFN
  1285.         .lStructSize = LenB(OFN)
  1286.         .hWndOwner = GetOwnerWindow()
  1287.         .hInstance = App.hInstance
  1288.         Filter = ProperFilter(PropFilter)
  1289.         .lpstrFilter = StrPtr(Filter)
  1290.         .nFilterIndex = PropFilterIndex
  1291.         If Not PropFileName = vbNullString Then Mid$(Buffer, 1, Len(PropFileName)) = PropFileName
  1292.         .lpstrFile = StrPtr(Buffer)
  1293.         .nMaxFile = Len(Buffer)
  1294.         .lpstrInitialDir = StrPtr(PropInitDir)
  1295.         .lpstrTitle = StrPtr(PropDialogTitle)
  1296.         If PropHookEvents = False Then
  1297.             .Flags = PropFlags
  1298.         Else
  1299.             .Flags = (OFN_ENABLEHOOK Or OFN_ENABLESIZING) Or PropFlags
  1300.             If (PropFlags And CdlOFNExplorer) = CdlOFNExplorer Then
  1301.                 .lpfnHook = ProcPtr(AddressOf ComCtlsCdlOFN2CallbackProc)
  1302.             Else
  1303.                 .lpfnHook = ProcPtr(AddressOf ComCtlsCdlOFN2CallbackProcOldStyle)
  1304.             End If
  1305.             Dim This As ISubclass
  1306.             Set This = Me
  1307.             .lCustData = ObjPtr(This)
  1308.         End If
  1309.         If PropDefaultExt = vbNullString Then DefaultExt = vbNullChar Else DefaultExt = PropDefaultExt
  1310.         .lpstrDefExt = StrPtr(DefaultExt)
  1311.     End With
  1312.     Dim RetVal As Long
  1313.     If (PropFlags And CdlOFNHelpButton) = CdlOFNHelpButton Then
  1314.         If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
  1315.         Call ComCtlsSetSubclass(OFN.hWndOwner, Me, 2, HELPMSGSTRING & "_2")
  1316.         RetVal = GetSaveFileName(OFN)
  1317.         Call ComCtlsRemoveSubclass(OFN.hWndOwner, HELPMSGSTRING & "_2")
  1318.     Else
  1319.         RetVal = GetSaveFileName(OFN)
  1320.     End If
  1321.     If RetVal <> 0 Then
  1322.         If (OFN.Flags And (OFN_ENABLEHOOK Or OFN_ENABLESIZING)) = 0 Then
  1323.             PropFlags = OFN.Flags
  1324.         Else
  1325.             PropFlags = OFN.Flags And Not (OFN_ENABLEHOOK Or OFN_ENABLESIZING)
  1326.         End If
  1327.         If OFN.nFileOffset > 0 Then
  1328.             If Mid$(Buffer, OFN.nFileOffset, 1) = vbNullChar Then
  1329.                 PropFileName = Left$(Buffer, InStr(Buffer & vbNullChar & vbNullChar, vbNullChar & vbNullChar) - 1)
  1330.                 PropFileTitle = vbNullString
  1331.             Else
  1332.                 PropFileName = Left$(Buffer, InStr(Buffer & vbNullChar, vbNullChar) - 1)
  1333.                 PropFileTitle = Mid$(PropFileName, OFN.nFileOffset + 1)
  1334.             End If
  1335.         End If
  1336.         PropFilterIndex = OFN.nFilterIndex
  1337.         PropFileOffset = OFN.nFileOffset
  1338.         ShowSave = True
  1339.     Else
  1340.         Dim ErrVal As Long
  1341.         ErrVal = CommDlgExtendedError()
  1342.         Select Case ErrVal
  1343.         Case FNERR_BUFFERTOOSMALL
  1344.             ERR.Raise Number:=CdlBufferTooSmall, Description:="The buffer at which the member lpstrFile points is too small."
  1345.         Case FNERR_INVALIDFILENAME
  1346.             ERR.Raise Number:=CdlInvalidFileName, Description:="File name is invalid."
  1347.         Case FNERR_SUBCLASSFAILURE
  1348.             ERR.Raise Number:=CdlSubclassFailure, Description:="An attempt to subclass a list box failed due to insufficient memory."
  1349.         Case 0
  1350.             If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
  1351.         Case Else
  1352.             ERR.Raise Number:=ErrVal, Description:="Unexpected error."
  1353.         End Select
  1354.     End If
  1355. End Function

  1356. ' Example for Filter: "Text Files (*.txt)|*.txt|All Files (*.*)|*.*"

  1357. Private Function ProperFilter(ByVal Filter As String) As String
  1358.     Dim i As Long, Sign As String, Temp As String
  1359.     For i = 1 To Len(Filter)
  1360.         Sign = Mid$(Filter, i, 1)
  1361.         If Sign = "|" Then
  1362.             Temp = Temp & vbNullChar
  1363.         Else
  1364.             Temp = Temp & Sign
  1365.         End If
  1366.     Next i
  1367.     Do Until Right$(Temp, 2) = vbNullChar & vbNullChar
  1368.         Temp = Temp & vbNullChar
  1369.     Loop
  1370.     ProperFilter = Temp
  1371. End Function

  1372. Public Function ShowColor() As Boolean
  1373.     Static CustomColors(0 To 15) As Long, CustomColorsInitialized As Boolean
  1374.     Dim CHCLR As TCHOOSECOLOR
  1375.     With CHCLR
  1376.         .lStructSize = LenB(CHCLR)
  1377.         .hWndOwner = GetOwnerWindow()
  1378.         .hInstance = App.hInstance
  1379.         .RGBResult = WinColor(PropColor)
  1380.         If PropHookEvents = False Then
  1381.             .Flags = PropFlags
  1382.         Else
  1383.             .Flags = CC_ENABLEHOOK Or PropFlags
  1384.             .lpfnHook = ProcPtr(AddressOf ComCtlsCdlCCCallbackProc)
  1385.             Dim This As ISubclass
  1386.             Set This = Me
  1387.             .lCustData = ObjPtr(This)
  1388.         End If
  1389.         If CustomColorsInitialized = False Then
  1390.             Dim i As Long, IntValue As Integer
  1391.             For i = 0 To 15
  1392.                 IntValue = 255 - (i * 16)
  1393.                 CustomColors(i) = RGB(IntValue, IntValue, IntValue)
  1394.             Next i
  1395.             CustomColorsInitialized = True
  1396.         End If
  1397.         .lpCustColors = VarPtr(CustomColors(0))
  1398.     End With
  1399.     Dim RetVal As Long
  1400.     If (PropFlags And CdlCCHelpButton) = CdlCCHelpButton Then
  1401.         If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
  1402.         Call ComCtlsSetSubclass(CHCLR.hWndOwner, Me, 3, HELPMSGSTRING & "_3")
  1403.         RetVal = ChooseColor(CHCLR)
  1404.         Call ComCtlsRemoveSubclass(CHCLR.hWndOwner, HELPMSGSTRING & "_3")
  1405.     Else
  1406.         RetVal = ChooseColor(CHCLR)
  1407.     End If
  1408.     If RetVal <> 0 Then
  1409.         If (CHCLR.Flags And CC_ENABLEHOOK) = 0 Then
  1410.             PropFlags = CHCLR.Flags
  1411.         Else
  1412.             PropFlags = CHCLR.Flags And Not CC_ENABLEHOOK
  1413.         End If
  1414.         PropColor = CHCLR.RGBResult
  1415.         ShowColor = True
  1416.     Else
  1417.         Dim ErrVal As Long
  1418.         ErrVal = CommDlgExtendedError()
  1419.         Select Case ErrVal
  1420.         Case 0
  1421.             If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
  1422.         Case Else
  1423.             ERR.Raise Number:=ErrVal, Description:="Unexpected error."
  1424.         End Select
  1425.     End If
  1426. End Function

  1427. Public Function ShowFont() As Boolean
  1428.     Dim CHFONT As TCHOOSEFONT, LF As LOGFONT, FontName As String
  1429.     With LF
  1430.         FontName = Left$(PropFontName, LF_FACESIZE)
  1431.         CopyMemory .LFFaceName(0), ByVal StrPtr(FontName), LenB(FontName)
  1432.         .LFHeight = -MulDiv(CLng(PropFontSize), DPI_Y(), 72)
  1433.         If PropFontBold = True Then .LFWeight = FW_BOLD Else .LFWeight = FW_NORMAL
  1434.         .LFItalic = IIf(PropFontItalic = True, 1, 0)
  1435.         .LFStrikeOut = IIf(PropFontStrikethru = True, 1, 0)
  1436.         .LFUnderline = IIf(PropFontUnderline = True, 1, 0)
  1437.         .LFQuality = DEFAULT_QUALITY
  1438.         .LFCharset = CByte(PropFontCharset And &HFF)
  1439.     End With
  1440.     With CHFONT
  1441.         .lStructSize = LenB(CHFONT)
  1442.         .hWndOwner = GetOwnerWindow()
  1443.         .lpLogFont = VarPtr(LF)
  1444.         If PropHookEvents = False Then
  1445.             .Flags = CF_INITTOLOGFONTSTRUCT Or PropFlags
  1446.         Else
  1447.             .Flags = (CF_INITTOLOGFONTSTRUCT Or CF_ENABLEHOOK) Or PropFlags
  1448.             .lpfnHook = ProcPtr(AddressOf ComCtlsCdlCFCallbackProc)
  1449.             Dim This As ISubclass
  1450.             Set This = Me
  1451.             .lCustData = ObjPtr(This)
  1452.         End If
  1453.         .RGBColor = WinColor(PropColor)
  1454.         .nSizeMin = PropMin
  1455.         .nSizeMax = PropMax
  1456.     End With
  1457.     Dim RetVal As Long
  1458.     If (PropFlags And CdlCFHelpButton) = CdlCFHelpButton Then
  1459.         If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
  1460.         Call ComCtlsSetSubclass(CHFONT.hWndOwner, Me, 4, HELPMSGSTRING & "_4")
  1461.         RetVal = ChooseFont(CHFONT)
  1462.         Call ComCtlsRemoveSubclass(CHFONT.hWndOwner, HELPMSGSTRING & "_4")
  1463.     Else
  1464.         RetVal = ChooseFont(CHFONT)
  1465.     End If
  1466.     If RetVal <> 0 Then
  1467.         With CHFONT
  1468.             If (.Flags And CF_ENABLEHOOK) = 0 Then
  1469.                 PropFlags = .Flags And Not CF_INITTOLOGFONTSTRUCT
  1470.             Else
  1471.                 PropFlags = .Flags And Not (CF_INITTOLOGFONTSTRUCT Or CF_ENABLEHOOK)
  1472.             End If
  1473.             If (.Flags And CF_NOFACESEL) = 0 Then PropFontName = Left$(LF.LFFaceName(), InStr(CStr(LF.LFFaceName()) & vbNullChar, vbNullChar) - 1)
  1474.             If (.Flags And CF_NOSTYLESEL) = 0 Then
  1475.                 PropFontBold = CBool(LF.LFWeight = FW_BOLD)
  1476.                 PropFontItalic = CBool(LF.LFItalic <> 0)
  1477.             End If
  1478.             If (.Flags And CF_NOSIZESEL) = 0 Then PropFontSize = CSng(.iPointSize / 10)
  1479.             If (.Flags And CF_EFFECTS) <> 0 Then
  1480.                 PropFontStrikethru = CBool(LF.LFStrikeOut <> 0)
  1481.                 PropFontUnderline = CBool(LF.LFUnderline <> 0)
  1482.                 PropColor = .RGBColor
  1483.             End If
  1484.             If (.Flags And CF_NOSCRIPTSEL) = 0 Then PropFontCharset = CInt(LF.LFCharset)
  1485.         End With
  1486.         ShowFont = True
  1487.     Else
  1488.         Dim ErrVal As Long
  1489.         ErrVal = CommDlgExtendedError()
  1490.         Select Case ErrVal
  1491.         Case CFERR_MAXLESSTHANMIN
  1492.             ERR.Raise Number:=CdlMaxLessThanMin, Description:="The size specified in the nSizeMax member is less than the size specified in the nSizeMin member."
  1493.         Case CFERR_NOFONTS
  1494.             ERR.Raise Number:=CdlNoFonts, Description:="No fonts exist."
  1495.         Case 0
  1496.             If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
  1497.         Case Else
  1498.             ERR.Raise Number:=ErrVal, Description:="Unexpected error."
  1499.         End Select
  1500.     End If
  1501. End Function

  1502. Public Function ShowPrinter() As Boolean
  1503.     Dim PDLG As PRINTDLG, DMODE As DEVMODE, DNAMES As DEVNAMES
  1504.     Dim lpDevMode As Long, lpDevNames As Long, Buffer As String
  1505.     With PDLG
  1506.         .lStructSize = Len(PDLG)                                                ' LenB() is not applicable due to padding bytes.
  1507.         .hWndOwner = GetOwnerWindow()
  1508.         If PropHookEvents = False Then
  1509.             .Flags = PropFlags
  1510.         Else
  1511.             .Flags = (PD_ENABLEPRINTHOOK Or PD_ENABLESETUPHOOK) Or PropFlags
  1512.             Dim DWord As Long
  1513.             DWord = ProcPtr(AddressOf ComCtlsCdlPDCallbackProc)
  1514.             .lpfnPrintHookLo = LoWord(DWord)
  1515.             .lpfnPrintHookHi = HiWord(DWord)
  1516.             .lpfnSetupHookLo = .lpfnPrintHookLo
  1517.             .lpfnSetupHookHi = .lpfnPrintHookHi
  1518.             Dim This As ISubclass
  1519.             Set This = Me
  1520.             DWord = ObjPtr(This)
  1521.             .lCustDataLo = LoWord(DWord)
  1522.             .lCustDataHi = HiWord(DWord)
  1523.         End If
  1524.         .nFromPage = CUIntToInt(PropFromPage And &HFFFF&)
  1525.         .nToPage = CUIntToInt(PropToPage And &HFFFF&)
  1526.         .nMinPage = CUIntToInt(PropMin And &HFFFF&)
  1527.         .nMaxPage = CUIntToInt(PropMax And &HFFFF&)
  1528.         .nCopies = PropCopies
  1529.     End With
  1530.     If (PDLG.Flags And CdlPDReturnDefault) = 0 Then
  1531.         DMODE.DMSize = LenB(DMODE)
  1532.         If PropPrinterDefaultInit = False And Not (PropPrinterDriver = vbNullString Or PropPrinterName = vbNullString Or PropPrinterPort = vbNullString) Then
  1533.             Buffer = Left$(PropPrinterName, CCHDEVICENAME)
  1534.             CopyMemory DMODE.DMDeviceName(0), ByVal StrPtr(Buffer), LenB(Buffer)
  1535.         End If
  1536.         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
  1537.         If (CommonDialogDMFieldsExclusion And DM_ORIENTATION) = 0 Then
  1538.             DMODE.DMOrientation = PropOrientation
  1539.         Else
  1540.             DMODE.DMFields = DMODE.DMFields And Not DM_ORIENTATION
  1541.         End If
  1542.         If (CommonDialogDMFieldsExclusion And DM_PAPERSIZE) = 0 Then
  1543.             DMODE.DMPaperSize = PropPaperSize
  1544.         Else
  1545.             DMODE.DMFields = DMODE.DMFields And Not DM_PAPERSIZE
  1546.         End If
  1547.         DMODE.DMCopies = PropCopies
  1548.         If (CommonDialogDMFieldsExclusion And DM_DEFAULTSOURCE) = 0 Then
  1549.             DMODE.DMDefaultSource = PropPaperBin
  1550.         Else
  1551.             DMODE.DMFields = DMODE.DMFields And Not DM_DEFAULTSOURCE
  1552.         End If
  1553.         If (CommonDialogDMFieldsExclusion And DM_PRINTQUALITY) = 0 Then
  1554.             DMODE.DMPrintQuality = PropPrintQuality
  1555.         Else
  1556.             DMODE.DMFields = DMODE.DMFields And Not DM_PRINTQUALITY
  1557.         End If
  1558.         If (CommonDialogDMFieldsExclusion And DM_COLOR) = 0 Then
  1559.             DMODE.DMColor = PropColorMode
  1560.         Else
  1561.             DMODE.DMFields = DMODE.DMFields And Not DM_COLOR
  1562.         End If
  1563.         If (CommonDialogDMFieldsExclusion And DM_DUPLEX) = 0 Then
  1564.             DMODE.DMDuplex = PropDuplex
  1565.         Else
  1566.             DMODE.DMFields = DMODE.DMFields And Not DM_DUPLEX
  1567.         End If
  1568.         DMODE.DMCollate = IIf((PDLG.Flags And CdlPDCollate) <> 0, 1, 0)
  1569.         PDLG.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, LenB(DMODE))
  1570.         lpDevMode = GlobalLock(PDLG.hDevMode)
  1571.         CopyMemory ByVal lpDevMode, DMODE, LenB(DMODE)
  1572.         GlobalUnlock PDLG.hDevMode
  1573.         If PropPrinterDefaultInit = False And Not (PropPrinterDriver = vbNullString Or PropPrinterName = vbNullString Or PropPrinterPort = vbNullString) Then
  1574.             DNAMES.wDriverOffset = 4
  1575.             DNAMES.wDeviceOffset = DNAMES.wDriverOffset + Len(PropPrinterDriver) + 1
  1576.             DNAMES.wOutputOffset = DNAMES.wDeviceOffset + Len(PropPrinterName) + 1
  1577.             DNAMES.wDefault = 0
  1578.             Buffer = Left$(PropPrinterName & vbNullChar & PropPrinterName & vbNullChar & PropPrinterPort & vbNullChar, CCHDEVNAMESEXTRA)
  1579.             CopyMemory DNAMES.wExtra(0), ByVal StrPtr(Buffer), LenB(Buffer)
  1580.             PDLG.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, LenB(DNAMES))
  1581.             lpDevNames = GlobalLock(PDLG.hDevNames)
  1582.             CopyMemory ByVal lpDevNames, DNAMES, LenB(DNAMES)
  1583.             GlobalUnlock PDLG.hDevNames
  1584.         End If
  1585.     End If
  1586.     Dim RetVal As Long
  1587.     If (PropFlags And CdlPDHelpButton) = CdlPDHelpButton Then
  1588.         If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
  1589.         Call ComCtlsSetSubclass(PDLG.hWndOwner, Me, 5, HELPMSGSTRING & "_5")
  1590.         RetVal = PrintDialog(PDLG)
  1591.         Call ComCtlsRemoveSubclass(PDLG.hWndOwner, HELPMSGSTRING & "_5")
  1592.     Else
  1593.         RetVal = PrintDialog(PDLG)
  1594.     End If
  1595.     If RetVal <> 0 Then
  1596.         lpDevMode = GlobalLock(PDLG.hDevMode)
  1597.         CopyMemory DMODE, ByVal lpDevMode, LenB(DMODE)
  1598.         GlobalUnlock PDLG.hDevMode
  1599.         GlobalFree PDLG.hDevMode
  1600.         lpDevNames = GlobalLock(PDLG.hDevNames)
  1601.         CopyMemory DNAMES, ByVal lpDevNames, LenB(DNAMES)
  1602.         GlobalUnlock PDLG.hDevNames
  1603.         GlobalFree PDLG.hDevNames
  1604.         If (DNAMES.wDefault And DN_DEFAULTPRN) = 0 Then
  1605.             Buffer = Mid$(DNAMES.wExtra, DNAMES.wDriverOffset - DNAMES.wDriverOffset + 1)
  1606.             PropPrinterDriver = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
  1607.             Buffer = Mid$(DNAMES.wExtra, DNAMES.wDeviceOffset - DNAMES.wDriverOffset + 1)
  1608.             PropPrinterName = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
  1609.             Buffer = Mid$(DNAMES.wExtra, DNAMES.wOutputOffset - DNAMES.wDriverOffset + 1)
  1610.             PropPrinterPort = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
  1611.             If PropPrinterDefault = True Then
  1612.                 Call SetPrinterDefault(PropPrinterName)
  1613.                 PropPrinterDriver = vbNullString
  1614.                 PropPrinterName = vbNullString
  1615.                 PropPrinterPort = vbNullString
  1616.             End If
  1617.         Else
  1618.             PropPrinterDriver = vbNullString
  1619.             PropPrinterName = vbNullString
  1620.             PropPrinterPort = vbNullString
  1621.         End If
  1622.         If (PDLG.Flags And (PD_ENABLEPRINTHOOK Or PD_ENABLESETUPHOOK)) = 0 Then
  1623.             PropFlags = PDLG.Flags
  1624.         Else
  1625.             PropFlags = PDLG.Flags And Not (PD_ENABLEPRINTHOOK Or PD_ENABLESETUPHOOK)
  1626.         End If
  1627.         If (DMODE.DMFields And DM_COLLATE) <> 0 Then
  1628.             If (PropFlags And CdlPDUseDevModeCopiesAndCollate) <> 0 Then
  1629.                 If DMODE.DMCollate = 1 And (PropFlags And CdlPDCollate) = 0 Then PropFlags = PropFlags Or CdlPDCollate
  1630.             End If
  1631.         End If
  1632.         If (DMODE.DMFields And DM_ORIENTATION) <> 0 Then
  1633.             PropOrientation = DMODE.DMOrientation
  1634.             If (CommonDialogDMFieldsExclusion And DM_ORIENTATION) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_ORIENTATION
  1635.         End If
  1636.         If (DMODE.DMFields And DM_PAPERSIZE) <> 0 Then
  1637.             PropPaperSize = DMODE.DMPaperSize
  1638.             If (CommonDialogDMFieldsExclusion And DM_PAPERSIZE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_PAPERSIZE
  1639.         End If
  1640.         If (DMODE.DMFields And DM_COPIES) <> 0 Then PropCopies = DMODE.DMCopies
  1641.         If (DMODE.DMFields And DM_DEFAULTSOURCE) <> 0 Then
  1642.             PropPaperBin = DMODE.DMDefaultSource
  1643.             If (CommonDialogDMFieldsExclusion And DM_DEFAULTSOURCE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_DEFAULTSOURCE
  1644.         End If
  1645.         If (DMODE.DMFields And DM_PRINTQUALITY) <> 0 Then
  1646.             PropPrintQuality = DMODE.DMPrintQuality
  1647.             If (CommonDialogDMFieldsExclusion And DM_PRINTQUALITY) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_PRINTQUALITY
  1648.         End If
  1649.         If (DMODE.DMFields And DM_COLOR) <> 0 Then
  1650.             PropColorMode = DMODE.DMColor
  1651.             If (CommonDialogDMFieldsExclusion And DM_COLOR) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_COLOR
  1652.         End If
  1653.         If (DMODE.DMFields And DM_DUPLEX) <> 0 Then
  1654.             PropDuplex = DMODE.DMDuplex
  1655.             If (CommonDialogDMFieldsExclusion And DM_DUPLEX) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_DUPLEX
  1656.         End If
  1657.         PropFromPage = CIntToUInt(PDLG.nFromPage)
  1658.         PropToPage = CIntToUInt(PDLG.nToPage)
  1659.         PropMin = CIntToUInt(PDLG.nMinPage)
  1660.         PropMax = CIntToUInt(PDLG.nMaxPage)
  1661.         If (PropFlags And (CdlPDReturnDC Or CdlPDReturnIC)) <> 0 Then
  1662.             If PropDC <> 0 Then DeleteObject PropDC
  1663.             PropDC = PDLG.hDC
  1664.         End If
  1665.         ShowPrinter = True
  1666.     Else
  1667.         If PDLG.hDevMode <> 0 Then GlobalFree PDLG.hDevMode
  1668.         If PDLG.hDevNames <> 0 Then GlobalFree PDLG.hDevNames
  1669.         Dim ErrVal As Long
  1670.         ErrVal = CommDlgExtendedError()
  1671.         Select Case ErrVal
  1672.         Case PDERR_PRINTERNOTFOUND
  1673.             ERR.Raise Number:=CdlPrinterNotFound, Description:="The [devices] section of WIN.INI does not contain an entry for the printer."
  1674.         Case PDERR_CREATEICFAILURE
  1675.             ERR.Raise Number:=CdlCreateICFailure, Description:="The PrintDlg function failed when creating an information context."
  1676.         Case PDERR_DNDMMISMATCH
  1677.             ERR.Raise Number:=CdlDndmMismatch, Description:="DevMode and DevNames data structures describe two different printers."
  1678.         Case PDERR_NODEFAULTPRN
  1679.             ERR.Raise Number:=CdlNoDefaultPrn, Description:="A default printer does not exist."
  1680.         Case PDERR_NODEVICES
  1681.             ERR.Raise Number:=CdlNoDevices, Description:="No printer device-drivers were found."
  1682.         Case PDERR_INITFAILURE
  1683.             ERR.Raise Number:=CdlInitFailure, Description:="The PrintDlg function failed during initialization."
  1684.         Case PDERR_GETDEVMODEFAIL
  1685.             ERR.Raise Number:=CdlGetDevModeFail, Description:="The printer-device driver failed to initialize a DevMode data structure."
  1686.         Case PDERR_LOADDRVFAILURE
  1687.             ERR.Raise Number:=CdlLoadDrvFailure, Description:="The PrintDlg function failed to load the specified printer's device driver."
  1688.         Case PDERR_RETDEFFAILURE
  1689.             ERR.Raise Number:=CdlRetDefFailure, Description:="The PDReturnDefault flag was set, but a field was nonzero."
  1690.         Case PDERR_PARSEFAILURE
  1691.             ERR.Raise Number:=CdlParseFailure, Description:="The PrintDlg function failed to parse the strings in WIN.INI."
  1692.         Case 0
  1693.             If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
  1694.         Case Else
  1695.             ERR.Raise Number:=ErrVal, Description:="Unexpected error."
  1696.         End Select
  1697.     End If
  1698. End Function

  1699. Public Function ShowPrinterEx() As CdlPDResultConstants
  1700.     Dim PDLGEX As PRINTDLGEX, PPAGERANGE As PRINTPAGERANGE, DMODE As DEVMODE, DNAMES As DEVNAMES
  1701.     Dim lpDevMode As Long, lpDevNames As Long, Buffer As String
  1702.     With PDLGEX
  1703.         .lStructSize = LenB(PDLGEX)
  1704.         .hWndOwner = GetOwnerWindow()
  1705.         .Flags = PropFlags
  1706.         .nPageRanges = 1
  1707.         .nMaxPageRanges = 1
  1708.         PPAGERANGE.nFromPage = PropFromPage
  1709.         PPAGERANGE.nToPage = PropToPage
  1710.         .nMinPage = PropMin
  1711.         .nMaxPage = PropMax
  1712.         .nCopies = PropCopies
  1713.         .lpPageRanges = VarPtr(PPAGERANGE)
  1714.         Const START_PAGE_GENERAL As Long = &HFFFFFFFF
  1715.         .nStartPage = START_PAGE_GENERAL
  1716.     End With
  1717.     If (PDLGEX.Flags And CdlPDReturnDefault) = 0 Then
  1718.         DMODE.DMSize = LenB(DMODE)
  1719.         If PropPrinterDefaultInit = False And Not (PropPrinterDriver = vbNullString Or PropPrinterName = vbNullString Or PropPrinterPort = vbNullString) Then
  1720.             Buffer = Left$(PropPrinterName, CCHDEVICENAME)
  1721.             CopyMemory DMODE.DMDeviceName(0), ByVal StrPtr(Buffer), LenB(Buffer)
  1722.         End If
  1723.         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
  1724.         If (CommonDialogDMFieldsExclusion And DM_ORIENTATION) = 0 Then
  1725.             DMODE.DMOrientation = PropOrientation
  1726.         Else
  1727.             DMODE.DMFields = DMODE.DMFields And Not DM_ORIENTATION
  1728.         End If
  1729.         If (CommonDialogDMFieldsExclusion And DM_PAPERSIZE) = 0 Then
  1730.             DMODE.DMPaperSize = PropPaperSize
  1731.         Else
  1732.             DMODE.DMFields = DMODE.DMFields And Not DM_PAPERSIZE
  1733.         End If
  1734.         DMODE.DMCopies = PropCopies
  1735.         If (CommonDialogDMFieldsExclusion And DM_DEFAULTSOURCE) = 0 Then
  1736.             DMODE.DMDefaultSource = PropPaperBin
  1737.         Else
  1738.             DMODE.DMFields = DMODE.DMFields And Not DM_DEFAULTSOURCE
  1739.         End If
  1740.         If (CommonDialogDMFieldsExclusion And DM_PRINTQUALITY) = 0 Then
  1741.             DMODE.DMPrintQuality = PropPrintQuality
  1742.         Else
  1743.             DMODE.DMFields = DMODE.DMFields And Not DM_PRINTQUALITY
  1744.         End If
  1745.         If (CommonDialogDMFieldsExclusion And DM_COLOR) = 0 Then
  1746.             DMODE.DMColor = PropColorMode
  1747.         Else
  1748.             DMODE.DMFields = DMODE.DMFields And Not DM_COLOR
  1749.         End If
  1750.         If (CommonDialogDMFieldsExclusion And DM_DUPLEX) = 0 Then
  1751.             DMODE.DMDuplex = PropDuplex
  1752.         Else
  1753.             DMODE.DMFields = DMODE.DMFields And Not DM_DUPLEX
  1754.         End If
  1755.         DMODE.DMCollate = IIf((PDLGEX.Flags And CdlPDCollate) <> 0, 1, 0)
  1756.         PDLGEX.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, LenB(DMODE))
  1757.         lpDevMode = GlobalLock(PDLGEX.hDevMode)
  1758.         CopyMemory ByVal lpDevMode, DMODE, LenB(DMODE)
  1759.         GlobalUnlock PDLGEX.hDevMode
  1760.         If PropPrinterDefaultInit = False And Not (PropPrinterDriver = vbNullString Or PropPrinterName = vbNullString Or PropPrinterPort = vbNullString) Then
  1761.             DNAMES.wDriverOffset = 4
  1762.             DNAMES.wDeviceOffset = DNAMES.wDriverOffset + Len(PropPrinterDriver) + 1
  1763.             DNAMES.wOutputOffset = DNAMES.wDeviceOffset + Len(PropPrinterName) + 1
  1764.             DNAMES.wDefault = 0
  1765.             Buffer = Left$(PropPrinterDriver & vbNullChar & PropPrinterName & vbNullChar & PropPrinterPort & vbNullChar, CCHDEVNAMESEXTRA)
  1766.             CopyMemory DNAMES.wExtra(0), ByVal StrPtr(Buffer), LenB(Buffer)
  1767.             PDLGEX.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, LenB(DNAMES))
  1768.             lpDevNames = GlobalLock(PDLGEX.hDevNames)
  1769.             CopyMemory ByVal lpDevNames, DNAMES, LenB(DNAMES)
  1770.             GlobalUnlock PDLGEX.hDevNames
  1771.         End If
  1772.     End If
  1773.     Dim ErrVal As Long
  1774.     If PropHookEvents = False Then
  1775.         ErrVal = PrintDialogEx(PDLGEX)
  1776.     Else
  1777.         PDLGEX.lpCallback = ComCtlsCdlPDEXCallbackPtr(Me)
  1778.         ErrVal = PrintDialogEx(PDLGEX)
  1779.     End If
  1780.     If ErrVal = S_OK Then
  1781.         If PDLGEX.dwResultAction <> CdlPDResultCancel Or (PDLGEX.Flags And CdlPDReturnDefault) <> 0 Then
  1782.             lpDevMode = GlobalLock(PDLGEX.hDevMode)
  1783.             CopyMemory DMODE, ByVal lpDevMode, LenB(DMODE)
  1784.             GlobalUnlock PDLGEX.hDevMode
  1785.             GlobalFree PDLGEX.hDevMode
  1786.             lpDevNames = GlobalLock(PDLGEX.hDevNames)
  1787.             CopyMemory DNAMES, ByVal lpDevNames, LenB(DNAMES)
  1788.             GlobalUnlock PDLGEX.hDevNames
  1789.             GlobalFree PDLGEX.hDevNames
  1790.             If (DNAMES.wDefault And DN_DEFAULTPRN) = 0 Then
  1791.                 Buffer = Mid$(DNAMES.wExtra, DNAMES.wDriverOffset - DNAMES.wDriverOffset + 1)
  1792.                 PropPrinterDriver = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
  1793.                 Buffer = Mid$(DNAMES.wExtra, DNAMES.wDeviceOffset - DNAMES.wDriverOffset + 1)
  1794.                 PropPrinterName = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
  1795.                 Buffer = Mid$(DNAMES.wExtra, DNAMES.wOutputOffset - DNAMES.wDriverOffset + 1)
  1796.                 PropPrinterPort = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
  1797.                 If PropPrinterDefault = True Then
  1798.                     Call SetPrinterDefault(PropPrinterName)
  1799.                     PropPrinterDriver = vbNullString
  1800.                     PropPrinterName = vbNullString
  1801.                     PropPrinterPort = vbNullString
  1802.                 End If
  1803.             Else
  1804.                 PropPrinterDriver = vbNullString
  1805.                 PropPrinterName = vbNullString
  1806.                 PropPrinterPort = vbNullString
  1807.             End If
  1808.             PropFlags = PDLGEX.Flags
  1809.             If (DMODE.DMFields And DM_COLLATE) <> 0 Then
  1810.                 If (PropFlags And CdlPDUseDevModeCopiesAndCollate) <> 0 Then
  1811.                     If DMODE.DMCollate = 1 And (PropFlags And CdlPDCollate) = 0 Then PropFlags = PropFlags Or CdlPDCollate
  1812.                 End If
  1813.             End If
  1814.             If (DMODE.DMFields And DM_ORIENTATION) <> 0 Then
  1815.                 PropOrientation = DMODE.DMOrientation
  1816.                 If (CommonDialogDMFieldsExclusion And DM_ORIENTATION) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_ORIENTATION
  1817.             End If
  1818.             If (DMODE.DMFields And DM_PAPERSIZE) <> 0 Then
  1819.                 PropPaperSize = DMODE.DMPaperSize
  1820.                 If (CommonDialogDMFieldsExclusion And DM_PAPERSIZE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_PAPERSIZE
  1821.             End If
  1822.             If (DMODE.DMFields And DM_COPIES) <> 0 Then PropCopies = DMODE.DMCopies
  1823.             If (DMODE.DMFields And DM_DEFAULTSOURCE) <> 0 Then
  1824.                 PropPaperBin = DMODE.DMDefaultSource
  1825.                 If (CommonDialogDMFieldsExclusion And DM_DEFAULTSOURCE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_DEFAULTSOURCE
  1826.             End If
  1827.             If (DMODE.DMFields And DM_PRINTQUALITY) <> 0 Then
  1828.                 PropPrintQuality = DMODE.DMPrintQuality
  1829.                 If (CommonDialogDMFieldsExclusion And DM_PRINTQUALITY) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_PRINTQUALITY
  1830.             End If
  1831.             If (DMODE.DMFields And DM_COLOR) <> 0 Then
  1832.                 PropColorMode = DMODE.DMColor
  1833.                 If (CommonDialogDMFieldsExclusion And DM_COLOR) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_COLOR
  1834.             End If
  1835.             If (DMODE.DMFields And DM_DUPLEX) <> 0 Then
  1836.                 PropDuplex = DMODE.DMDuplex
  1837.                 If (CommonDialogDMFieldsExclusion And DM_DUPLEX) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_DUPLEX
  1838.             End If
  1839.             PropFromPage = PPAGERANGE.nFromPage
  1840.             PropToPage = PPAGERANGE.nToPage
  1841.             PropMin = PDLGEX.nMinPage
  1842.             PropMax = PDLGEX.nMaxPage
  1843.             If (PropFlags And (CdlPDReturnDC Or CdlPDReturnIC)) <> 0 Then
  1844.                 If PropDC <> 0 Then DeleteObject PropDC
  1845.                 PropDC = PDLGEX.hDC
  1846.             End If
  1847.             ShowPrinterEx = PDLGEX.dwResultAction
  1848.         Else
  1849.             If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
  1850.         End If
  1851.     Else
  1852.         If PDLGEX.hDevMode <> 0 Then GlobalFree PDLGEX.hDevMode
  1853.         If PDLGEX.hDevNames <> 0 Then GlobalFree PDLGEX.hDevNames
  1854.         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
  1855.         Select Case ErrVal
  1856.         Case E_OUTOFMEMORY, E_INVALIDARG, E_POINTER, E_HANDLE, E_FAIL
  1857.             ERR.Raise Number:=CdlInitFailure, Description:="The PrintDlgEx function failed during initialization."
  1858.         Case Else
  1859.             ERR.Raise Number:=ErrVal, Description:="Unexpected error."
  1860.         End Select
  1861.     End If
  1862. End Function

  1863. Public Sub ShowHelp()
  1864.     If PropHelpCommand = 0 Then Exit Sub
  1865.     Dim dwData As Long
  1866.     Select Case PropHelpCommand
  1867.     Case CdlHelpKey, CdlHelpCommandHelp, CdlHelpPartialKey
  1868.         dwData = StrPtr(PropHelpKey)
  1869.     Case CdlHelpContext, CdlHelpSetIndex, CdlHelpSetContents, CdlHelpContextPopup
  1870.         dwData = PropHelpContext
  1871.     Case CdlHelpQuit, CdlHelpIndex, CdlHelpContents, CdlHelpHelpOnHelp, CdlHelpForceFile
  1872.         dwData = 0
  1873.     End Select
  1874.     If WinHelp(0, StrPtr(PropHelpFile), PropHelpCommand, dwData) = 0 Then ERR.Raise Number:=CdlHelp, Description:="Call to windows help failed."
  1875. End Sub

  1876. Public Function ShowPageSetup() As Boolean
  1877.     Dim PSDLG As PAGESETUPDLG, DMODE As DEVMODE, DNAMES As DEVNAMES
  1878.     Dim lpDevMode As Long, lpDevNames As Long
  1879.     Dim ObjPrinter As VB.Printer, NewPrinterName As String, Buffer As String
  1880.     With PSDLG
  1881.         .lStructSize = LenB(PSDLG)
  1882.         .hWndOwner = GetOwnerWindow()
  1883.         If PropHookEvents = False Then
  1884.             .Flags = PropFlags
  1885.         Else
  1886.             .Flags = PSD_ENABLEPAGESETUPHOOK Or PropFlags
  1887.             .lpfnPageSetupHook = ProcPtr(AddressOf ComCtlsCdlPSDCallbackProc)
  1888.             Dim This As ISubclass
  1889.             Set This = Me
  1890.             .lCustData = ObjPtr(This)
  1891.         End If
  1892.         .RCMargin.Left = PropPageLeftMargin
  1893.         .RCMargin.Top = PropPageTopMargin
  1894.         .RCMargin.Right = PropPageRightMargin
  1895.         .RCMargin.Bottom = PropPageBottomMargin
  1896.         .RCMinMargin.Left = PropPageLeftMinMargin
  1897.         .RCMinMargin.Top = PropPageTopMinMargin
  1898.         .RCMinMargin.Right = PropPageRightMinMargin
  1899.         .RCMinMargin.Bottom = PropPageBottomMinMargin
  1900.     End With
  1901.     If (PSDLG.Flags And CdlPSDReturnDefault) = 0 Then
  1902.         DMODE.DMSize = LenB(DMODE)
  1903.         If PropPrinterDefaultInit = False And Not (PropPrinterDriver = vbNullString Or PropPrinterName = vbNullString Or PropPrinterPort = vbNullString) Then
  1904.             Buffer = Left$(PropPrinterName, CCHDEVICENAME)
  1905.             CopyMemory DMODE.DMDeviceName(0), ByVal StrPtr(Buffer), LenB(Buffer)
  1906.         End If
  1907.         DMODE.DMFields = DM_ORIENTATION Or DM_PAPERSIZE Or DM_DEFAULTSOURCE
  1908.         If (CommonDialogDMFieldsExclusion And DM_ORIENTATION) = 0 Then
  1909.             DMODE.DMOrientation = PropOrientation
  1910.         Else
  1911.             DMODE.DMFields = DMODE.DMFields And Not DM_ORIENTATION
  1912.         End If
  1913.         If (CommonDialogDMFieldsExclusion And DM_PAPERSIZE) = 0 Then
  1914.             DMODE.DMPaperSize = PropPaperSize
  1915.         Else
  1916.             DMODE.DMFields = DMODE.DMFields And Not DM_PAPERSIZE
  1917.         End If
  1918.         If (CommonDialogDMFieldsExclusion And DM_DEFAULTSOURCE) = 0 Then
  1919.             DMODE.DMDefaultSource = PropPaperBin
  1920.         Else
  1921.             DMODE.DMFields = DMODE.DMFields And Not DM_DEFAULTSOURCE
  1922.         End If
  1923.         PSDLG.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, LenB(DMODE))
  1924.         lpDevMode = GlobalLock(PSDLG.hDevMode)
  1925.         CopyMemory ByVal lpDevMode, DMODE, LenB(DMODE)
  1926.         GlobalUnlock PSDLG.hDevMode
  1927.         If PropPrinterDefaultInit = False And Not (PropPrinterDriver = vbNullString Or PropPrinterName = vbNullString Or PropPrinterPort = vbNullString) Then
  1928.             DNAMES.wDriverOffset = 4
  1929.             DNAMES.wDeviceOffset = DNAMES.wDriverOffset + Len(PropPrinterDriver) + 1
  1930.             DNAMES.wOutputOffset = DNAMES.wDeviceOffset + Len(PropPrinterName) + 1
  1931.             DNAMES.wDefault = 0
  1932.             Buffer = Left$(PropPrinterDriver & vbNullChar & PropPrinterName & vbNullChar & PropPrinterPort & vbNullChar, CCHDEVNAMESEXTRA)
  1933.             CopyMemory DNAMES.wExtra(0), ByVal StrPtr(Buffer), LenB(Buffer)
  1934.             PSDLG.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, LenB(DNAMES))
  1935.             lpDevNames = GlobalLock(PSDLG.hDevNames)
  1936.             CopyMemory ByVal lpDevNames, DNAMES, LenB(DNAMES)
  1937.             GlobalUnlock PSDLG.hDevNames
  1938.         End If
  1939.     End If
  1940.     Dim RetVal As Long
  1941.     If (PropFlags And CdlPSDHelpButton) = CdlPSDHelpButton Then
  1942.         If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
  1943.         Call ComCtlsSetSubclass(PSDLG.hWndOwner, Me, 7, HELPMSGSTRING & "_7")
  1944.         RetVal = PageSetupDialog(PSDLG)
  1945.         Call ComCtlsRemoveSubclass(PSDLG.hWndOwner, HELPMSGSTRING & "_7")
  1946.     Else
  1947.         RetVal = PageSetupDialog(PSDLG)
  1948.     End If
  1949.     If RetVal <> 0 Then
  1950.         lpDevMode = GlobalLock(PSDLG.hDevMode)
  1951.         CopyMemory DMODE, ByVal lpDevMode, LenB(DMODE)
  1952.         GlobalUnlock PSDLG.hDevMode
  1953.         GlobalFree PSDLG.hDevMode
  1954.         lpDevNames = GlobalLock(PSDLG.hDevNames)
  1955.         CopyMemory DNAMES, ByVal lpDevNames, LenB(DNAMES)
  1956.         GlobalUnlock PSDLG.hDevNames
  1957.         GlobalFree PSDLG.hDevNames
  1958.         If (PSDLG.Flags And PSD_ENABLEPAGESETUPHOOK) = 0 Then
  1959.             PropFlags = PSDLG.Flags
  1960.         Else
  1961.             PropFlags = PSDLG.Flags And Not PSD_ENABLEPAGESETUPHOOK
  1962.         End If
  1963.         If (DMODE.DMFields And DM_ORIENTATION) <> 0 Then
  1964.             PropOrientation = DMODE.DMOrientation
  1965.             If (CommonDialogDMFieldsExclusion And DM_ORIENTATION) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_ORIENTATION
  1966.         End If
  1967.         If (DMODE.DMFields And DM_PAPERSIZE) <> 0 Then
  1968.             PropPaperSize = DMODE.DMPaperSize
  1969.             If (CommonDialogDMFieldsExclusion And DM_PAPERSIZE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_PAPERSIZE
  1970.         End If
  1971.         If (DMODE.DMFields And DM_DEFAULTSOURCE) <> 0 Then
  1972.             PropPaperBin = DMODE.DMDefaultSource
  1973.             If (CommonDialogDMFieldsExclusion And DM_DEFAULTSOURCE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_DEFAULTSOURCE
  1974.         End If
  1975.         PropPageLeftMargin = PSDLG.RCMargin.Left
  1976.         PropPageTopMargin = PSDLG.RCMargin.Top
  1977.         PropPageRightMargin = PSDLG.RCMargin.Right
  1978.         PropPageBottomMargin = PSDLG.RCMargin.Bottom
  1979.         ShowPageSetup = True
  1980.     Else
  1981.         If PSDLG.hDevMode <> 0 Then GlobalFree PSDLG.hDevMode
  1982.         If PSDLG.hDevNames <> 0 Then GlobalFree PSDLG.hDevNames
  1983.         Dim ErrVal As Long
  1984.         ErrVal = CommDlgExtendedError()
  1985.         Select Case ErrVal
  1986.         Case PDERR_PRINTERNOTFOUND
  1987.             ERR.Raise Number:=CdlPrinterNotFound, Description:="The [devices] section of WIN.INI does not contain an entry for the printer."
  1988.         Case PDERR_CREATEICFAILURE
  1989.             ERR.Raise Number:=CdlCreateICFailure, Description:="The PageSetupDlg function failed when creating an information context."
  1990.         Case PDERR_DNDMMISMATCH
  1991.             ERR.Raise Number:=CdlDndmMismatch, Description:="DevMode and DevNames data structures describe two different printers."
  1992.         Case PDERR_NODEFAULTPRN
  1993.             ERR.Raise Number:=CdlNoDefaultPrn, Description:="A default printer does not exist."
  1994.         Case PDERR_NODEVICES
  1995.             ERR.Raise Number:=CdlNoDevices, Description:="No printer device-drivers were found."
  1996.         Case PDERR_INITFAILURE
  1997.             ERR.Raise Number:=CdlInitFailure, Description:="The PageSetupDlg function failed during initialization."
  1998.         Case PDERR_GETDEVMODEFAIL
  1999.             ERR.Raise Number:=CdlGetDevModeFail, Description:="The printer-device driver failed to initialize a DevMode data structure."
  2000.         Case PDERR_LOADDRVFAILURE
  2001.             ERR.Raise Number:=CdlLoadDrvFailure, Description:="The PageSetupDlg function failed to load the specified printer's device driver."
  2002.         Case PDERR_RETDEFFAILURE
  2003.             ERR.Raise Number:=CdlRetDefFailure, Description:="The PDReturnDefault flag was set, but a field was nonzero."
  2004.         Case PDERR_PARSEFAILURE
  2005.             ERR.Raise Number:=CdlParseFailure, Description:="The PageSetupDlg function failed to parse the strings in WIN.INI."
  2006.         Case 0
  2007.             If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
  2008.         Case Else
  2009.             ERR.Raise Number:=ErrVal, Description:="Unexpected error."
  2010.         End Select
  2011.     End If
  2012. End Function

  2013. Private Sub SetPrinterDefault(ByVal NewPrinterName As String)
  2014.     Dim Length As Long
  2015.     GetDefaultPrinter 0, Length
  2016.     If Length > 0 Then
  2017.         Dim Buffer As String
  2018.         Buffer = String(Length, vbNullChar)
  2019.         GetDefaultPrinter StrPtr(Buffer), Length
  2020.         If StrComp(Left$(Buffer, InStr(Buffer, vbNullChar) - 1), NewPrinterName, vbTextCompare) <> 0 Then SetDefaultPrinter StrPtr(NewPrinterName)
  2021.     End If
  2022. End Sub

  2023. Public Function ShowFolderBrowser() As Boolean
  2024.     Dim BIF As BROWSEINFO, IDList As Long
  2025.     With BIF
  2026.         .hWndOwner = GetOwnerWindow()
  2027.         Select Case VarType(PropRootFolder)
  2028.         Case vbEmpty
  2029.             .pIDLRoot = 0
  2030.         Case vbLong, vbInteger, vbByte
  2031.             SHGetFolderLocation 0, PropRootFolder, 0, 0, .pIDLRoot
  2032.         Case vbString
  2033.             If ComCtlsW2KCompatibility() = False Then
  2034.                 .pIDLRoot = ILCreateFromPath(StrPtr(Left$(PropRootFolder, MAX_PATH)))
  2035.             Else
  2036.                 .pIDLRoot = ILCreateFromPath_W2K(StrPtr(Left$(PropRootFolder, MAX_PATH)))
  2037.             End If
  2038.         Case vbDouble, vbSingle
  2039.             SHGetFolderLocation 0, CLng(PropRootFolder), 0, 0, .pIDLRoot
  2040.         End Select
  2041.         .lpszTitle = StrPtr(PropDialogTitle)
  2042.         .ulFlags = PropFlags
  2043.         .lpfnCallback = ProcPtr(AddressOf ComCtlsCdlBIFCallbackProc)
  2044.         Dim This As ISubclass
  2045.         Set This = Me
  2046.         .lParam = ObjPtr(This)
  2047.         IDList = SHBrowseForFolder(BIF)
  2048.         If .pIDLRoot <> 0 Then CoTaskMemFree .pIDLRoot
  2049.     End With
  2050.     If IDList <> 0 Then
  2051.         Dim Buffer As String, PathName As String
  2052.         Buffer = String(MAX_PATH, vbNullChar)
  2053.         If SHGetPathFromIDList(IDList, StrPtr(Buffer)) <> 0 Then PathName = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
  2054.         CoTaskMemFree IDList
  2055.         On Error Resume Next
  2056.         Dim Attributes As VbFileAttribute
  2057.         Attributes = GetAttr(PathName)
  2058.         On Error GoTo 0
  2059.         If (Attributes And (vbDirectory Or vbVolume)) <> 0 Then
  2060.             If Not PathName = vbNullString Then PathName = PathName & IIf(Right$(PathName, 1) = "\", "", "\")
  2061.             PropFileOffset = 0
  2062.             PropFileTitle = vbNullString
  2063.         Else
  2064.             PropFileOffset = InStrRev(PathName, "\")
  2065.             PropFileTitle = Mid$(PathName, PropFileOffset + 1)
  2066.         End If
  2067.         PropFileName = PathName
  2068.         ShowFolderBrowser = True
  2069.     Else
  2070.         If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
  2071.     End If
  2072. End Function

  2073. Public Function ShowFind() As Long
  2074.     If CommonDialogFRDialogHandle <> 0 Then Exit Function
  2075.     Dim FR As FINDREPLACE
  2076.     LSet CommonDialogFR = FR
  2077.     With CommonDialogFR
  2078.         .lStructSize = LenB(CommonDialogFR)
  2079.         .hWndOwner = GetOwnerWindow()
  2080.         If PropHookEvents = False Then
  2081.             .Flags = PropFlags
  2082.         Else
  2083.             .Flags = FR_ENABLEHOOK Or PropFlags
  2084.             .lpfnHook = ProcPtr(AddressOf ComCtlsCdlFR1CallbackProc)
  2085.             Dim This As ISubclass
  2086.             Set This = Me
  2087.             .lCustData = ObjPtr(This)
  2088.         End If
  2089.         CommonDialogFRBufferFindWhat = PropFindWhat
  2090.         If StrPtr(CommonDialogFRBufferFindWhat) = 0 Then CommonDialogFRBufferFindWhat = ""
  2091.         .lpstrFindWhat = StrPtr(CommonDialogFRBufferFindWhat)
  2092.         .wFindWhatLen = 256
  2093.     End With
  2094.     If (PropFlags And CdlFRHelpButton) = CdlFRHelpButton Then
  2095.         If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
  2096.     End If
  2097.     If CommonDialogFindMsg = 0 Then CommonDialogFindMsg = RegisterWindowMessage(StrPtr(FINDMSGSTRING))
  2098.     CommonDialogFRDialogHandle = FindText(CommonDialogFR)
  2099.     If CommonDialogFRDialogHandle <> 0 Then
  2100.         With CommonDialogFR
  2101.             .lCustData = CommonDialogFRDialogHandle
  2102.             Call ComCtlsSetSubclass(.hWndOwner, Me, 9, FINDMSGSTRING & "_9_" & CStr(.lCustData))
  2103.             Call ComCtlsCdlFRAddHook(.lCustData)
  2104.             ShowFind = .lCustData
  2105.         End With
  2106.     Else
  2107.         Dim ErrVal As Long
  2108.         ErrVal = CommDlgExtendedError()
  2109.         Select Case ErrVal
  2110.         Case FRERR_BUFFERLENGTHZERO
  2111.             ERR.Raise Number:=CdlBufferLengthZero, Description:="The buffer at which the member LpstrFindWhat points is invalid."
  2112.         Case Else
  2113.             ERR.Raise Number:=ErrVal, Description:="Unexpected error."
  2114.         End Select
  2115.     End If
  2116. End Function

  2117. Public Function ShowReplace() As Long
  2118.     If CommonDialogFRDialogHandle <> 0 Then Exit Function
  2119.     Dim FR As FINDREPLACE
  2120.     LSet CommonDialogFR = FR
  2121.     With CommonDialogFR
  2122.         .lStructSize = LenB(CommonDialogFR)
  2123.         .hWndOwner = GetOwnerWindow()
  2124.         If PropHookEvents = False Then
  2125.             .Flags = PropFlags
  2126.         Else
  2127.             .Flags = FR_ENABLEHOOK Or PropFlags
  2128.             .lpfnHook = ProcPtr(AddressOf ComCtlsCdlFR2CallbackProc)
  2129.             Dim This As ISubclass
  2130.             Set This = Me
  2131.             .lCustData = ObjPtr(This)
  2132.         End If
  2133.         CommonDialogFRBufferFindWhat = PropFindWhat
  2134.         If StrPtr(CommonDialogFRBufferFindWhat) = 0 Then CommonDialogFRBufferFindWhat = ""
  2135.         .lpstrFindWhat = StrPtr(CommonDialogFRBufferFindWhat)
  2136.         CommonDialogFRBufferReplaceWith = PropReplaceWith
  2137.         If StrPtr(CommonDialogFRBufferReplaceWith) = 0 Then CommonDialogFRBufferReplaceWith = ""
  2138.         .lpstrReplaceWith = StrPtr(CommonDialogFRBufferReplaceWith)
  2139.         .wFindWhatLen = 256
  2140.         .wReplaceWithLen = 256
  2141.     End With
  2142.     If (PropFlags And CdlFRHelpButton) = CdlFRHelpButton Then
  2143.         If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
  2144.     End If
  2145.     If CommonDialogFindMsg = 0 Then CommonDialogFindMsg = RegisterWindowMessage(StrPtr(FINDMSGSTRING))
  2146.     CommonDialogFRDialogHandle = ReplaceText(CommonDialogFR)
  2147.     If CommonDialogFRDialogHandle <> 0 Then
  2148.         With CommonDialogFR
  2149.             .lCustData = CommonDialogFRDialogHandle
  2150.             Call ComCtlsSetSubclass(.hWndOwner, Me, 10, FINDMSGSTRING & "_10_" & CStr(.lCustData))
  2151.             Call ComCtlsCdlFRAddHook(.lCustData)
  2152.             ShowReplace = .lCustData
  2153.         End With
  2154.     Else
  2155.         Dim ErrVal As Long
  2156.         ErrVal = CommDlgExtendedError()
  2157.         Select Case ErrVal
  2158.         Case FRERR_BUFFERLENGTHZERO
  2159.             ERR.Raise Number:=CdlBufferLengthZero, Description:="The buffer at which the member LpstrFindWhat and/or LpstrReplaceWith points is invalid."
  2160.         Case Else
  2161.             ERR.Raise Number:=ErrVal, Description:="Unexpected error."
  2162.         End Select
  2163.     End If
  2164. End Function

  2165. Private Function GetOwnerWindow() As Long
  2166.     Dim hwnd As Long, hWndMDIClient As Long
  2167.     hwnd = GetActiveWindow()
  2168.     If hwnd <> 0 Then hWndMDIClient = FindWindowEx(hwnd, 0, StrPtr("MDIClient"), 0)
  2169.     If hWndMDIClient <> 0 Then
  2170.         Const WM_MDIGETACTIVE As Long = &H229
  2171.         GetOwnerWindow = SendMessage(hWndMDIClient, WM_MDIGETACTIVE, 0, ByVal 0&)
  2172.     Else
  2173.         GetOwnerWindow = hwnd
  2174.     End If
  2175. End Function

  2176. 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
  2177.     If dwRefData > 0 Then
  2178.         ISubclass_Message = WindowProcOwner(hwnd, wMsg, wParam, lParam, dwRefData)
  2179.     Else
  2180.         ISubclass_Message = CallbackProcDialog(hwnd, wMsg, wParam, lParam, dwRefData)
  2181.     End If
  2182. End Function

  2183. 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
  2184.     Dim hWndFocus As Long
  2185.     If wMsg = CommonDialogHelpMsg And CommonDialogHelpMsg <> 0 Then
  2186.         Dim Handled As Boolean
  2187.         hWndFocus = GetFocus()
  2188.         RaiseEvent Help(Handled, CUIntToInt(dwRefData And &HFFFF&), wParam)
  2189.         If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
  2190.         If Handled = False Then Me.ShowHelp
  2191.     End If
  2192.     If wMsg = CommonDialogFindMsg And CommonDialogFindMsg <> 0 Then
  2193.         Dim FR As FINDREPLACE
  2194.         CopyMemory ByVal VarPtr(FR), ByVal lParam, LenB(FR)
  2195.         If (FR.lCustData = CommonDialogFRDialogHandle Or FR.lCustData = 0) And CommonDialogFRDialogHandle <> 0 Then
  2196.             If (FR.Flags And FR_DIALOGTERM) = FR_DIALOGTERM Then
  2197.                 WindowProcOwner = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
  2198.                 Call ComCtlsRemoveSubclass(hwnd, FINDMSGSTRING & "_" & CStr(dwRefData) & "_" & CStr(CommonDialogFRDialogHandle))
  2199.                 Call ComCtlsCdlFRReleaseHook(CommonDialogFRDialogHandle)
  2200.                 CommonDialogFRDialogHandle = 0
  2201.                 Exit Function
  2202.             Else
  2203.                 If (FR.Flags And FR_ENABLEHOOK) = 0 Then
  2204.                     PropFlags = FR.Flags
  2205.                 Else
  2206.                     PropFlags = FR.Flags And Not FR_ENABLEHOOK
  2207.                 End If
  2208.                 Dim Length As Long
  2209.                 If FR.lpstrFindWhat <> 0 Then
  2210.                     Length = lstrlen(FR.lpstrFindWhat)
  2211.                     PropFindWhat = String(Length, vbNullChar)
  2212.                     CopyMemory ByVal StrPtr(PropFindWhat), ByVal FR.lpstrFindWhat, Length * 2
  2213.                 End If
  2214.                 If FR.lpstrReplaceWith <> 0 Then
  2215.                     Length = lstrlen(FR.lpstrReplaceWith)
  2216.                     PropReplaceWith = String(Length, vbNullChar)
  2217.                     CopyMemory ByVal StrPtr(PropReplaceWith), ByVal FR.lpstrReplaceWith, Length * 2
  2218.                 End If
  2219.                 hWndFocus = GetFocus()
  2220.                 Select Case True
  2221.                 Case CBool((FR.Flags And CdlFRFindNext) = CdlFRFindNext)
  2222.                     RaiseEvent FindNext
  2223.                 Case CBool((FR.Flags And CdlFRReplace) = CdlFRReplace)
  2224.                     RaiseEvent Replace
  2225.                 Case CBool((FR.Flags And CdlFRReplaceAll) = CdlFRFindNext)
  2226.                     RaiseEvent ReplaceAll
  2227.                 End Select
  2228.                 If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
  2229.             End If
  2230.         End If
  2231.     End If
  2232.     WindowProcOwner = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
  2233. End Function

  2234. 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
  2235.     Dim hWndFocus As Long, Cancel As Boolean, Buffer As String, Length As Long
  2236.     CallbackProcDialog = 0
  2237.     Select Case dwRefData
  2238.     Case -1, -2, -1001, -1002
  2239.         Dim OFN As OPENFILENAME, FileName As String, Result As CdlOFNShareViResultConstants
  2240.         If dwRefData > -1000 Then
  2241.             If wMsg = WM_NOTIFY Then
  2242.                 Dim NM As NMHDR, NMOFN As NMOFNOTIFY
  2243.                 CopyMemory NM, ByVal lParam, LenB(NM)
  2244.                 Const H_MAX As Long = (&HFFFF + 1)
  2245.                 Const CDN_FIRST As Long = (H_MAX - 601)
  2246.                 Const CDN_INITDONE As Long = (CDN_FIRST - 0)
  2247.                 Const CDN_SHAREVIOLATION As Long = (CDN_FIRST - 3)
  2248.                 Const CDN_FILEOK As Long = (CDN_FIRST - 5)
  2249.                 Select Case NM.Code
  2250.                 Case CDN_INITDONE
  2251.                     RaiseEvent InitDialog(CUIntToInt(-dwRefData And &HFFFF&), hDlg)
  2252.                 Case CDN_SHAREVIOLATION
  2253.                     CopyMemory NMOFN, ByVal lParam, LenB(NMOFN)
  2254.                     Buffer = String(PropMaxFileSize, vbNullChar)
  2255.                     With NMOFN
  2256.                         If .lpszFileShareVi <> 0 Then
  2257.                             Length = lstrlen(.lpszFileShareVi)
  2258.                             If Length > PropMaxFileSize Then Length = PropMaxFileSize
  2259.                             CopyMemory ByVal StrPtr(Buffer), ByVal .lpszFileShareVi, Length * 2
  2260.                         End If
  2261.                     End With
  2262.                     hWndFocus = GetFocus()
  2263.                     FileName = Left$(Buffer, InStr(Buffer & vbNullChar, vbNullChar) - 1)
  2264.                     RaiseEvent FileShareViolation(FileName, Result, hDlg)
  2265.                     If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
  2266.                     CallbackProcDialog = Result
  2267.                     SetWindowLong hDlg, DWL_MSGRESULT, Result
  2268.                 Case CDN_FILEOK
  2269.                     CopyMemory NMOFN, ByVal lParam, LenB(NMOFN)
  2270.                     If NMOFN.lpOFN <> 0 Then CopyMemory OFN, ByVal NMOFN.lpOFN, ByVal LenB(OFN)
  2271.                     With OFN
  2272.                         Buffer = String(PropMaxFileSize, vbNullChar)
  2273.                         If .lpstrFile <> 0 Then
  2274.                             Length = lstrlen(.lpstrFile)
  2275.                             If Length > PropMaxFileSize Then Length = PropMaxFileSize
  2276.                             CopyMemory ByVal StrPtr(Buffer), ByVal .lpstrFile, Length * 2
  2277.                         End If
  2278.                         hWndFocus = GetFocus()
  2279.                         If .nFileOffset > 0 Then
  2280.                             If Mid$(Buffer, .nFileOffset, 1) = vbNullChar Then
  2281.                                 FileName = Left$(Buffer, InStr(Buffer & vbNullChar & vbNullChar, vbNullChar & vbNullChar) - 1)
  2282.                                 RaiseEvent FileValidate(FileName, vbNullString, .nFileOffset, Cancel, hDlg)
  2283.                             Else
  2284.                                 FileName = Left$(Buffer, InStr(Buffer & vbNullChar, vbNullChar) - 1)
  2285.                                 RaiseEvent FileValidate(FileName, Mid$(FileName, .nFileOffset + 1), .nFileOffset, Cancel, hDlg)
  2286.                             End If
  2287.                         End If
  2288.                         If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
  2289.                     End With
  2290.                     If Cancel = True Then
  2291.                         CallbackProcDialog = 1
  2292.                         SetWindowLong hDlg, DWL_MSGRESULT, 1
  2293.                     End If
  2294.                 End Select
  2295.             End If
  2296.         Else
  2297.             If wMsg = WM_INITDIALOG Then
  2298.                 If CommonDialogShareViMsg = 0 Then CommonDialogShareViMsg = RegisterWindowMessage(StrPtr(SHAREVISTRING))
  2299.                 If CommonDialogFileOKMsg = 0 Then CommonDialogFileOKMsg = RegisterWindowMessage(StrPtr(FILEOKSTRING))
  2300.                 RaiseEvent InitDialog(CUIntToInt(-(dwRefData + 1000) And &HFFFF&), hDlg)
  2301.             ElseIf wMsg = CommonDialogShareViMsg And CommonDialogShareViMsg <> 0 Then
  2302.                 Buffer = String(PropMaxFileSize, vbNullChar)
  2303.                 If lParam <> 0 Then
  2304.                     Length = lstrlen(lParam)
  2305.                     If Length > PropMaxFileSize Then Length = PropMaxFileSize
  2306.                     CopyMemory ByVal StrPtr(Buffer), ByVal lParam, Length * 2
  2307.                 End If
  2308.                 hWndFocus = GetFocus()
  2309.                 FileName = Left$(Buffer, InStr(Buffer & vbNullChar, vbNullChar) - 1)
  2310.                 RaiseEvent FileShareViolation(FileName, Result, hDlg)
  2311.                 If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
  2312.                 CallbackProcDialog = Result
  2313.             ElseIf wMsg = CommonDialogFileOKMsg And CommonDialogFileOKMsg <> 0 Then
  2314.                 CopyMemory OFN, ByVal lParam, LenB(OFN)
  2315.                 With OFN
  2316.                     Buffer = String(PropMaxFileSize, vbNullChar)
  2317.                     If .lpstrFile <> 0 Then
  2318.                         Length = lstrlen(.lpstrFile)
  2319.                         If Length > PropMaxFileSize Then Length = PropMaxFileSize
  2320.                         CopyMemory ByVal StrPtr(Buffer), ByVal .lpstrFile, Length * 2
  2321.                     End If
  2322.                     hWndFocus = GetFocus()
  2323.                     If .nFileOffset > 0 Then
  2324.                         If Mid$(Buffer, .nFileOffset, 1) = vbNullChar Then
  2325.                             FileName = Left$(Buffer, InStr(Buffer & vbNullChar & vbNullChar, vbNullChar & vbNullChar) - 1)
  2326.                             RaiseEvent FileValidate(FileName, vbNullString, .nFileOffset, Cancel, hDlg)
  2327.                         Else
  2328.                             FileName = Left$(Buffer, InStr(Buffer & vbNullChar, vbNullChar) - 1)
  2329.                             RaiseEvent FileValidate(FileName, Mid$(FileName, .nFileOffset + 1), .nFileOffset, Cancel, hDlg)
  2330.                         End If
  2331.                     End If
  2332.                     If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
  2333.                 End With
  2334.                 If Cancel = True Then CallbackProcDialog = 1
  2335.             End If
  2336.         End If
  2337.     Case -3
  2338.         If wMsg = WM_INITDIALOG Then
  2339.             If CommonDialogColorOKMsg = 0 Then CommonDialogColorOKMsg = RegisterWindowMessage(StrPtr(COLOROKSTRING))
  2340.             RaiseEvent InitDialog(CUIntToInt(-dwRefData And &HFFFF&), hDlg)
  2341.         ElseIf wMsg = CommonDialogColorOKMsg And CommonDialogColorOKMsg <> 0 Then
  2342.             Dim CHCLR As TCHOOSECOLOR, OldColor As Long
  2343.             CopyMemory CHCLR, ByVal lParam, LenB(CHCLR)
  2344.             With CHCLR
  2345.                 OldColor = .RGBResult
  2346.                 hWndFocus = GetFocus()
  2347.                 RaiseEvent ColorValidate(.RGBResult, Cancel, hDlg)
  2348.                 If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
  2349.                 If Cancel = True Then
  2350.                     CallbackProcDialog = 1
  2351.                     If OldColor <> .RGBResult Then                              ' The SetRGB message works only properly when the callback procedure returns a nonzero value
  2352.                         If CommonDialogSetRGBMsg = 0 Then CommonDialogSetRGBMsg = RegisterWindowMessage(StrPtr(SETRGBSTRING))
  2353.                         SendMessage hDlg, CommonDialogSetRGBMsg, 0, ByVal .RGBResult
  2354.                     End If
  2355.                 End If
  2356.             End With
  2357.         End If
  2358.     Case -4
  2359.         If wMsg = WM_INITDIALOG Then
  2360.             RaiseEvent InitDialog(CUIntToInt(-dwRefData And &HFFFF&), hDlg)
  2361.         ElseIf wMsg = WM_COMMAND Then
  2362.             If HiWord(wParam) = BN_CLICKED Then
  2363.                 Const IDC_APPLY_BUTTON As Long = 1026
  2364.                 If LoWord(wParam) = IDC_APPLY_BUTTON Then
  2365.                     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
  2366.                     Const CB_ERR As Long = (-1)
  2367.                     Const CB_GETCURSEL As Long = &H147
  2368.                     Const CB_GETITEMDATA As Long = &H150
  2369.                     Dim Flags As Long, iItem As Long
  2370.                     Flags = PropFlags
  2371.                     ' The CdlCFNo***Sel flags needs to be adjusted, if necessary.
  2372.                     iItem = SendDlgItemMessage(hDlg, IDC_FACE_COMBOBOX, CB_GETCURSEL, 0, ByVal 0&)
  2373.                     If (Flags And CdlCFNoFaceSel) = 0 Then
  2374.                         If iItem = CB_ERR Then Flags = Flags Or CdlCFNoFaceSel
  2375.                     ElseIf (Flags And CdlCFNoFaceSel) = CdlCFNoFaceSel Then
  2376.                         If Not iItem = CB_ERR Then Flags = Flags And Not CdlCFNoFaceSel
  2377.                     End If
  2378.                     iItem = SendDlgItemMessage(hDlg, IDC_STYLE_COMBOBOX, CB_GETCURSEL, 0, ByVal 0&)
  2379.                     If (Flags And CdlCFNoStyleSel) = 0 Then
  2380.                         If iItem = CB_ERR Then Flags = Flags Or CdlCFNoStyleSel
  2381.                     ElseIf (Flags And CdlCFNoStyleSel) = CdlCFNoStyleSel Then
  2382.                         If Not iItem = CB_ERR Then Flags = Flags And Not CdlCFNoStyleSel
  2383.                     End If
  2384.                     iItem = SendDlgItemMessage(hDlg, IDC_SIZE_COMBOBOX, CB_GETCURSEL, 0, ByVal 0&)
  2385.                     If (Flags And CdlCFNoSizeSel) = 0 Then
  2386.                         If iItem = CB_ERR Then Flags = Flags Or CdlCFNoSizeSel
  2387.                     ElseIf (Flags And CdlCFNoSizeSel) = CdlCFNoSizeSel Then
  2388.                         If Not iItem = CB_ERR Then Flags = Flags And Not CdlCFNoSizeSel
  2389.                     End If
  2390.                     iItem = SendDlgItemMessage(hDlg, IDC_SCRIPT_COMBOBOX, CB_GETCURSEL, 0, ByVal 0&)
  2391.                     If (Flags And CdlCFNoScriptSel) = 0 Then
  2392.                         If iItem = CB_ERR Then Flags = Flags Or CdlCFNoScriptSel
  2393.                     ElseIf (Flags And CdlCFNoScriptSel) = CdlCFNoScriptSel Then
  2394.                         If Not iItem = CB_ERR Then Flags = Flags And Not CdlCFNoScriptSel
  2395.                     End If
  2396.                     Const WM_CHOOSEFONT_GETLOGFONT As Long = (WM_USER + 1)
  2397.                     Dim LF As LOGFONT, RGBColor As Long
  2398.                     SendMessage hDlg, WM_CHOOSEFONT_GETLOGFONT, 0, ByVal VarPtr(LF)
  2399.                     iItem = SendDlgItemMessage(hDlg, IDC_COLOR_COMBOBOX, CB_GETCURSEL, 0, ByVal 0&)
  2400.                     If Not iItem = CB_ERR Then RGBColor = SendDlgItemMessage(hDlg, IDC_COLOR_COMBOBOX, CB_GETITEMDATA, iItem, ByVal 0&)
  2401.                     With LF
  2402.                         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)
  2403.                     End With
  2404.                 End If
  2405.             End If
  2406.         End If
  2407.     Case -5, -7
  2408.         If wMsg = WM_INITDIALOG Then RaiseEvent InitDialog(CUIntToInt(-dwRefData And &HFFFF&), hDlg)
  2409.     Case -8
  2410.         Dim Text As String
  2411.         Const BFFM_INITIALIZED As Long = 1, BFFM_SELCHANGED As Long = 2, BFFM_VALIDATEFAILED As Long = 4
  2412.         Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
  2413.         Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
  2414.         Const BFFM_SETSTATUSTEXT As Long = BFFM_SETSTATUSTEXTW
  2415.         Const BFFM_ENABLEOK As Long = (WM_USER + 101)
  2416.         Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
  2417.         Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
  2418.         Const BFFM_SETSELECTION As Long = BFFM_SETSELECTIONW
  2419.         Select Case wMsg
  2420.         Case BFFM_INITIALIZED
  2421.             If Not PropInitDir = vbNullString Then SendMessage hDlg, BFFM_SETSELECTION, 1, ByVal StrPtr(PropInitDir)
  2422.             RaiseEvent InitDialog(CUIntToInt(-dwRefData And &HFFFF&), hDlg)
  2423.         Case BFFM_SELCHANGED
  2424.             Dim RetVal As Long
  2425.             If lParam <> 0 Then
  2426.                 Buffer = String(MAX_PATH, vbNullChar)
  2427.                 RetVal = SHGetPathFromIDList(lParam, StrPtr(Buffer))
  2428.                 If RetVal <> 0 Then
  2429.                     Text = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
  2430.                     On Error Resume Next
  2431.                     Dim Attributes As VbFileAttribute
  2432.                     Attributes = GetAttr(Text)
  2433.                     On Error GoTo 0
  2434.                     If (Attributes And (vbDirectory Or vbVolume)) <> 0 Then If Not Text = vbNullString Then Text = Text & IIf(Right$(Text, 1) = "\", "", "\")
  2435.                 End If
  2436.             End If
  2437.             If (PropFlags And CdlBIFStatusText) = CdlBIFStatusText Then SendMessage hDlg, BFFM_SETSTATUSTEXT, 0, ByVal StrPtr(Text)
  2438.             If (PropFlags And CdlBIFReturnOnlyFSDirs) = CdlBIFReturnOnlyFSDirs Then
  2439.                 ' If the CdlBIFReturnOnlyFSDirs flag is set, the OK button remains enabled if the user selects a "\\ServerName" item.
  2440.                 ' "\\ServerName" is not a file system path, but a machine name. Whereas "\\ServerName\ShareName\" is a file system path.
  2441.                 ' Therefore it is necessary to check the return value of SHGetPathFromIDList and enable/disable the OK button accordingly.
  2442.                 SendMessage hDlg, BFFM_ENABLEOK, 0, ByVal RetVal
  2443.             End If
  2444.         Case BFFM_VALIDATEFAILED
  2445.             If lParam <> 0 Then
  2446.                 Length = lstrlen(lParam)
  2447.                 Text = String(Length, vbNullChar)
  2448.                 CopyMemory ByVal StrPtr(Text), ByVal lParam, Length * 2
  2449.             End If
  2450.             hWndFocus = GetFocus()
  2451.             RaiseEvent FolderBrowserValidateFailed(Text, Cancel, hDlg)
  2452.             If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
  2453.             If Cancel = True Then CallbackProcDialog = 1
  2454.         End Select
  2455.     Case -9, -10
  2456.         If wMsg = WM_INITDIALOG Then RaiseEvent InitDialog(CUIntToInt(-dwRefData And &HFFFF&), hDlg)
  2457.     End Select
  2458. End Function
复制代码
cStringBuilder
  1. '字符串构建类

  2. '原作者:巴西_prince
  3. '原网站链接:https://cloud.tencent.com/developer/article/1496152
  4. '原发布时间:2019-08-28

  5. Option Explicit

  6. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
  7.       (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
  8.       
  9.       
  10. Private m_sString As String
  11. Private m_iChunkSize As Long
  12. Private m_iPos As Long
  13. Private m_iLen As Long

  14. Public Property Get Length() As Long
  15.    Length = m_iPos \ 2
  16. End Property

  17. Public Property Get Capacity() As Long
  18.    Capacity = m_iLen \ 2
  19. End Property

  20. Public Property Get ChunkSize() As Long
  21.    ChunkSize = m_iChunkSize \ 2
  22. End Property

  23. Public Property Let ChunkSize(ByVal iChunkSize As Long)
  24.    m_iChunkSize = iChunkSize * 2
  25. End Property

  26. Public Property Get toString() As String
  27.    If m_iPos > 0 Then
  28.       toString = Left$(m_sString, m_iPos \ 2)
  29.    End If
  30. End Property

  31. Public Property Let TheString(ByRef sThis As String)
  32.    Dim lLen As Long
  33.    lLen = LenB(sThis)
  34.    If lLen = 0 Then
  35.       m_sString = ""
  36.       m_iPos = 0
  37.       m_iLen = 0
  38.    Else
  39.       If m_iLen < lLen Then
  40.          Do
  41.             m_sString = m_sString & Space$(m_iChunkSize \ 2)
  42.             m_iLen = m_iLen + m_iChunkSize
  43.          Loop While m_iLen < lLen
  44.       End If
  45.       CopyMemory ByVal StrPtr(m_sString), ByVal StrPtr(sThis), lLen
  46.       m_iPos = lLen
  47.    End If
  48.    
  49. End Property

  50. Public Sub Clear()
  51.    m_sString = ""
  52.    m_iPos = 0
  53.    m_iLen = 0
  54. End Sub

  55. Public Sub AppendNL(ByRef sThis As String)
  56.    Append sThis
  57.    Append vbCrLf
  58. End Sub

  59. Public Sub Append(ByRef sThis As String)
  60.    Dim lLen As Long
  61.    Dim lLenPlusPos As Long
  62.    lLen = LenB(sThis)
  63.    lLenPlusPos = lLen + m_iPos
  64.    If lLenPlusPos > m_iLen Then
  65.       Dim lTemp As Long
  66.       
  67.       lTemp = m_iLen
  68.       Do While lTemp < lLenPlusPos
  69.          lTemp = lTemp + m_iChunkSize
  70.       Loop
  71.       
  72.       m_sString = m_sString & Space$((lTemp - m_iLen) \ 2)
  73.       m_iLen = lTemp
  74.    End If
  75.    
  76.    CopyMemory ByVal UnsignedAdd(StrPtr(m_sString), m_iPos), ByVal StrPtr(sThis), lLen
  77.    m_iPos = m_iPos + lLen
  78. End Sub

  79. Public Sub AppendByVal(ByVal sThis As String)
  80.    Append sThis
  81. End Sub

  82. Public Sub Insert(ByVal iIndex As Long, ByRef sThis As String)
  83.    Dim lLen As Long
  84.    Dim lPos As Long
  85.    Dim lSize As Long
  86.    If (iIndex * 2 > m_iPos) Then
  87.       ERR.Raise 9
  88.    Else
  89.    
  90.       lLen = LenB(sThis)
  91.       If (m_iPos + lLen) > m_iLen Then
  92.          m_sString = m_sString & Space$(m_iChunkSize \ 2)
  93.          m_iLen = m_iLen + m_iChunkSize
  94.       End If
  95.       lPos = UnsignedAdd(StrPtr(m_sString), iIndex * 2)
  96.       lSize = m_iPos - iIndex * 2
  97.       CopyMemory ByVal UnsignedAdd(lPos, lLen), ByVal lPos, lSize
  98.       CopyMemory ByVal lPos, ByVal StrPtr(sThis), lLen
  99.       
  100.       m_iPos = m_iPos + lLen
  101.    End If
  102. End Sub

  103. Public Sub InsertByVal(ByVal iIndex As Long, ByVal sThis As String)
  104.    Insert iIndex, sThis
  105. End Sub

  106. Public Sub Remove(ByVal iIndex As Long, ByVal lLen As Long)
  107.    Dim lSrc As Long
  108.    Dim lDst As Long
  109.    Dim lSize As Long

  110.    If (iIndex * 2 > m_iPos) Then
  111.       ERR.Raise 9
  112.    Else
  113.       If ((iIndex + lLen) * 2 > m_iPos) Then
  114.          ERR.Raise 9
  115.       Else
  116.          lSrc = UnsignedAdd(StrPtr(m_sString), (iIndex + lLen) * 2)
  117.          lDst = UnsignedAdd(StrPtr(m_sString), iIndex * 2)
  118.          lSize = (m_iPos - (iIndex + lLen) * 2)
  119.          CopyMemory ByVal lDst, ByVal lSrc, lSize
  120.          m_iPos = m_iPos - lLen * 2
  121.       End If
  122.    End If
  123. End Sub

  124. Public Function Find(ByVal sToFind As String, _
  125.    Optional ByVal lStartIndex As Long = 1, _
  126.    Optional ByVal compare As VbCompareMethod = vbTextCompare _
  127.    ) As Long
  128.    
  129.    Dim lInstr As Long
  130.    If (lStartIndex > 0) Then
  131.       lInstr = InStr(lStartIndex, m_sString, sToFind, compare)
  132.    Else
  133.       lInstr = InStr(m_sString, sToFind, compare)
  134.    End If
  135.    If (lInstr < m_iPos \ 2) Then
  136.       Find = lInstr
  137.    End If
  138. End Function

  139. Public Sub HeapMinimize()
  140.    Dim iLen As Long
  141.    If (m_iLen - m_iPos) > m_iChunkSize Then
  142.       iLen = m_iLen
  143.       Do While (iLen - m_iPos) > m_iChunkSize
  144.          iLen = iLen - m_iChunkSize
  145.       Loop
  146.       m_sString = Left$(m_sString, iLen \ 2)
  147.       m_iLen = iLen
  148.    End If
  149.    
  150. End Sub
  151. Private Function UnsignedAdd(Start As Long, Incr As Long) As Long

  152.    If Start And &H80000000 Then
  153.       UnsignedAdd = Start + Incr
  154.    ElseIf (Start Or &H80000000) < -Incr Then
  155.       UnsignedAdd = Start + Incr
  156.    Else
  157.       UnsignedAdd = (Start + &H80000000) + (Incr + &H80000000)
  158.    End If
  159.    
  160. End Function
  161. Private Sub Class_Initialize()
  162.    m_iChunkSize = 16384
  163. End Sub
复制代码
JSON.cls
  1.    
  2. '将json的花括号转化为vba的字典,将方括号转化为vba的集合
  3. Option Explicit

  4. Const INVALID_JSON As Long = 1
  5. Const INVALID_OBJECT As Long = 2
  6. Const INVALID_ARRAY As Long = 3
  7. Const INVALID_BOOLEAN As Long = 4
  8. Const INVALID_NULL As Long = 5
  9. Const INVALID_KEY As Long = 6
  10. Const INVALID_RPC_CALL As Long = 7

  11. Private psErrors As String

  12. Public Function GetParserErrors() As String
  13.     GetParserErrors = psErrors
  14. End Function

  15. Public Function ClearParserErrors() As String
  16.     psErrors = ""
  17. End Function


  18. '
  19. '   解析字符串并创建JSON对象
  20. '
  21. Public Function parse(ByVal str As String) As Object
  22.    
  23.     Dim Index As Long
  24.     Index = 1
  25.     psErrors = ""
  26.     On Error Resume Next
  27.     Call skipChar(str, Index)
  28.     Select Case Mid(str, Index, 1)
  29.     Case "{"
  30.         Set parse = parseObject(str, Index)
  31.     Case "["
  32.         Set parse = parseArray(str, Index)
  33.     Case Else
  34.         psErrors = "Invalid JSON"
  35.     End Select
  36.    
  37.    
  38. End Function

  39. '
  40. '   解析键/值的集合
  41. '
  42. Private Function parseObject(ByRef str As String, ByRef Index As Long) As Object
  43.    
  44.     Set parseObject = CreateObject("Scripting.Dictionary")
  45.     Dim sKey As String
  46.    
  47.     ' "{"
  48.     Call skipChar(str, Index)
  49.     If Mid(str, Index, 1) <> "{" Then
  50.         psErrors = psErrors & "Invalid Object at position " & Index & " : " & Mid(str, Index) & vbCrLf
  51.         Exit Function
  52.     End If
  53.    
  54.     Index = Index + 1
  55.    
  56.     Do
  57.         Call skipChar(str, Index)
  58.         If "}" = Mid(str, Index, 1) Then
  59.             Index = Index + 1
  60.             Exit Do
  61.         ElseIf "," = Mid(str, Index, 1) Then
  62.             Index = Index + 1
  63.             Call skipChar(str, Index)
  64.         ElseIf Index > Len(str) Then
  65.             psErrors = psErrors & "Missing '}': " & Right(str, 20) & vbCrLf
  66.             Exit Do
  67.         End If
  68.         
  69.         
  70.         ' 添加键/值对
  71.         sKey = parseKey(str, Index)
  72.         On Error Resume Next
  73.         
  74.         parseObject.Add sKey, parseValue(str, Index)
  75.         If ERR.Number <> 0 Then
  76.             psErrors = psErrors & ERR.Description & ": " & sKey & vbCrLf
  77.             Exit Do
  78.         End If
  79.     Loop
  80. eh:
  81.    
  82. End Function

  83. '
  84. '   解析列表
  85. '
  86. Private Function parseArray(ByRef str As String, ByRef Index As Long) As Collection
  87.    
  88.     Set parseArray = New Collection
  89.    
  90.     ' "["
  91.     Call skipChar(str, Index)
  92.     If Mid(str, Index, 1) <> "[" Then
  93.         psErrors = psErrors & "Invalid Array at position " & Index & " : " + Mid(str, Index, 20) & vbCrLf
  94.         Exit Function
  95.     End If
  96.    
  97.     Index = Index + 1
  98.    
  99.     Do
  100.         
  101.         Call skipChar(str, Index)
  102.         If "]" = Mid(str, Index, 1) Then
  103.             Index = Index + 1
  104.             Exit Do
  105.         ElseIf "," = Mid(str, Index, 1) Then
  106.             Index = Index + 1
  107.             Call skipChar(str, Index)
  108.         ElseIf Index > Len(str) Then
  109.             psErrors = psErrors & "Missing ']': " & Right(str, 20) & vbCrLf
  110.             Exit Do
  111.         End If
  112.         
  113.         ' 添加值
  114.         On Error Resume Next
  115.         parseArray.Add parseValue(str, Index)
  116.         If ERR.Number <> 0 Then
  117.             psErrors = psErrors & ERR.Description & ": " & Mid(str, Index, 20) & vbCrLf
  118.             Exit Do
  119.         End If
  120.     Loop
  121.    
  122. End Function

  123. '
  124. '   解析字符串/数字/对象/数组/真/假/空
  125. '
  126. Private Function parseValue(ByRef str As String, ByRef Index As Long)
  127.    
  128.     Call skipChar(str, Index)
  129.    
  130.     Select Case Mid(str, Index, 1)
  131.     Case "{"
  132.         Set parseValue = parseObject(str, Index)
  133.     Case "["
  134.         Set parseValue = parseArray(str, Index)
  135.     Case """", "'"
  136.         parseValue = parseString(str, Index)
  137.     Case "t", "f"
  138.         parseValue = parseBoolean(str, Index)
  139.     Case "n"
  140.         parseValue = parseNull(str, Index)
  141.     Case Else
  142.         parseValue = parseNumber(str, Index)
  143.     End Select
  144.    
  145. End Function

  146. '
  147. '   解析字符串
  148. '
  149. Private Function parseString(ByRef str As String, ByRef Index As Long) As String
  150.    
  151.     Dim quote As String
  152.     Dim Char As String
  153.     Dim Code As String
  154.    
  155.     Dim SB As New cStringBuilder
  156.    
  157.     Call skipChar(str, Index)
  158.     quote = Mid(str, Index, 1)
  159.     Index = Index + 1
  160.    
  161.     Do While Index > 0 And Index <= Len(str)
  162.         Char = Mid(str, Index, 1)
  163.         Select Case (Char)
  164.         Case "\"
  165.             Index = Index + 1
  166.             Char = Mid(str, Index, 1)
  167.             Select Case (Char)
  168.             Case """", "\", "/", "'"
  169.                 SB.Append Char
  170.                 Index = Index + 1
  171.             Case "b"
  172.                 SB.Append vbBack
  173.                 Index = Index + 1
  174.             Case "f"
  175.                 SB.Append vbFormFeed
  176.                 Index = Index + 1
  177.             Case "n"
  178.                 SB.Append vbLf
  179.                 Index = Index + 1
  180.             Case "r"
  181.                 SB.Append vbCr
  182.                 Index = Index + 1
  183.             Case "t"
  184.                 SB.Append vbTab
  185.                 Index = Index + 1
  186.             Case "u"
  187.                 Index = Index + 1
  188.                 Code = Mid(str, Index, 4)
  189.                 SB.Append ChrW(Val("&h" + Code))
  190.                 Index = Index + 4
  191.             End Select
  192.         Case quote
  193.             Index = Index + 1
  194.             
  195.             parseString = SB.toString
  196.             Set SB = Nothing
  197.             
  198.             Exit Function
  199.             
  200.         Case Else
  201.             SB.Append Char
  202.             Index = Index + 1
  203.         End Select
  204.     Loop
  205.    
  206.     parseString = SB.toString
  207.     Set SB = Nothing
  208.    
  209. End Function

  210. '
  211. '   解析数字
  212. '
  213. Private Function parseNumber(ByRef str As String, ByRef Index As Long)
  214.    
  215.     Dim Value As String
  216.     Dim Char As String
  217.    
  218.     Call skipChar(str, Index)
  219.     Do While Index > 0 And Index <= Len(str)
  220.         Char = Mid(str, Index, 1)
  221.         If InStr("+-0123456789.eE", Char) Then
  222.             Value = Value & Char
  223.             Index = Index + 1
  224.         Else
  225.             parseNumber = CDec(Value)
  226.             Exit Function
  227.         End If
  228.     Loop
  229. End Function

  230. '
  231. '   解析真/假
  232. '
  233. Private Function parseBoolean(ByRef str As String, ByRef Index As Long) As Boolean
  234.    
  235.     Call skipChar(str, Index)
  236.     If Mid(str, Index, 4) = "true" Then
  237.         parseBoolean = True
  238.         Index = Index + 4
  239.     ElseIf Mid(str, Index, 5) = "false" Then
  240.         parseBoolean = False
  241.         Index = Index + 5
  242.     Else
  243.         psErrors = psErrors & "Invalid Boolean at position " & Index & " : " & Mid(str, Index) & vbCrLf
  244.     End If
  245.    
  246. End Function

  247. '
  248. '   解析空
  249. '
  250. Private Function parseNull(ByRef str As String, ByRef Index As Long)
  251.    
  252.     Call skipChar(str, Index)
  253.     If Mid(str, Index, 4) = "null" Then
  254.         parseNull = Null
  255.         Index = Index + 4
  256.     Else
  257.         psErrors = psErrors & "Invalid null value at position " & Index & " : " & Mid(str, Index) & vbCrLf
  258.     End If
  259.    
  260. End Function

  261. Private Function parseKey(ByRef str As String, ByRef Index As Long) As String
  262.    
  263.     Dim dquote As Boolean
  264.     Dim squote As Boolean
  265.     Dim Char As String
  266.    
  267.     Call skipChar(str, Index)
  268.     Do While Index > 0 And Index <= Len(str)
  269.         Char = Mid(str, Index, 1)
  270.         Select Case (Char)
  271.         Case """"
  272.             dquote = Not dquote
  273.             Index = Index + 1
  274.             If Not dquote Then
  275.                 Call skipChar(str, Index)
  276.                 If Mid(str, Index, 1) <> ":" Then
  277.                     psErrors = psErrors & "Invalid Key at position " & Index & " : " & parseKey & vbCrLf
  278.                     Exit Do
  279.                 End If
  280.             End If
  281.         Case "'"
  282.             squote = Not squote
  283.             Index = Index + 1
  284.             If Not squote Then
  285.                 Call skipChar(str, Index)
  286.                 If Mid(str, Index, 1) <> ":" Then
  287.                     psErrors = psErrors & "Invalid Key at position " & Index & " : " & parseKey & vbCrLf
  288.                     Exit Do
  289.                 End If
  290.             End If
  291.         Case ":"
  292.             Index = Index + 1
  293.             If Not dquote And Not squote Then
  294.                 Exit Do
  295.             Else
  296.                 parseKey = parseKey & Char
  297.             End If
  298.         Case Else
  299.             If InStr(vbCrLf & vbCr & vbLf & vbTab & " ", Char) Then
  300.             Else
  301.                 parseKey = parseKey & Char
  302.             End If
  303.             Index = Index + 1
  304.         End Select
  305.     Loop
  306.    
  307. End Function

  308. '
  309. '   跳过特殊字符
  310. '
  311. Private Sub skipChar(ByRef str As String, ByRef Index As Long)
  312.     Dim bComment As Boolean
  313.     Dim bStartComment As Boolean
  314.     Dim bLongComment As Boolean
  315.     Do While Index > 0 And Index <= Len(str)
  316.         Select Case Mid(str, Index, 1)
  317.         Case vbCr, vbLf
  318.             If Not bLongComment Then
  319.                 bStartComment = False
  320.                 bComment = False
  321.             End If
  322.             
  323.         Case vbTab, " ", "(", ")"
  324.             
  325.         Case "/"
  326.             If Not bLongComment Then
  327.                 If bStartComment Then
  328.                     bStartComment = False
  329.                     bComment = True
  330.                 Else
  331.                     bStartComment = True
  332.                     bComment = False
  333.                     bLongComment = False
  334.                 End If
  335.             Else
  336.                 If bStartComment Then
  337.                     bLongComment = False
  338.                     bStartComment = False
  339.                     bComment = False
  340.                 End If
  341.             End If
  342.             
  343.         Case "*"
  344.             If bStartComment Then
  345.                 bStartComment = False
  346.                 bComment = True
  347.                 bLongComment = True
  348.             Else
  349.                 bStartComment = True
  350.             End If
  351.             
  352.         Case Else
  353.             If Not bComment Then
  354.                 Exit Do
  355.             End If
  356.         End Select
  357.         
  358.         Index = Index + 1
  359.     Loop
  360.    
  361. End Sub

  362. Public Function toString(ByRef obj As Variant) As String
  363.     Dim SB As New cStringBuilder
  364.     Select Case VarType(obj)
  365.     Case vbNull
  366.         SB.Append "null"
  367.     Case vbDate
  368.         SB.Append """" & CStr(obj) & """"
  369.     Case vbString
  370.         SB.Append """" & Encode(obj) & """"
  371.     Case vbObject
  372.         
  373.         Dim bFI As Boolean
  374.         Dim i As Long
  375.         
  376.         bFI = True
  377.         If TypeName(obj) = "Dictionary" Then
  378.             
  379.             SB.Append "{"
  380.             Dim keys
  381.             keys = obj.keys
  382.             For i = 0 To obj.Count - 1
  383.                 If bFI Then bFI = False Else SB.Append ","
  384.                 Dim key
  385.                 key = keys(i)
  386.                 SB.Append """" & key & """:" & toString(obj.Item(key))
  387.             Next i
  388.             SB.Append "}"
  389.             
  390.         ElseIf TypeName(obj) = "Collection" Then
  391.             
  392.             SB.Append "["
  393.             Dim Value
  394.             For Each Value In obj
  395.                 If bFI Then bFI = False Else SB.Append ","
  396.                 SB.Append toString(Value)
  397.             Next Value
  398.             SB.Append "]"
  399.             
  400.         End If
  401.     Case vbBoolean
  402.         If obj Then SB.Append "true" Else SB.Append "false"
  403.     Case vbVariant, vbArray, vbArray + vbVariant
  404.         Dim sEB
  405.         SB.Append multiArray(obj, 1, "", sEB)
  406.     Case Else
  407.         SB.Append Replace(obj, ",", ".")
  408.     End Select
  409.    
  410.     toString = SB.toString
  411.     Set SB = Nothing
  412.    
  413. End Function

  414. Private Function Encode(str) As String
  415.    
  416.     Dim SB As New cStringBuilder
  417.     Dim i As Long
  418.     Dim j As Long
  419.     Dim aL1 As Variant
  420.     Dim aL2 As Variant
  421.     Dim c As String
  422.     Dim p As Boolean
  423.    
  424.     aL1 = Array(&H22, &H5C, &H2F, &H8, &HC, &HA, &HD, &H9)
  425.     aL2 = Array(&H22, &H5C, &H2F, &H62, &H66, &H6E, &H72, &H74)
  426.     For i = 1 To Len(str)
  427.         p = True
  428.         c = Mid(str, i, 1)
  429.         For j = 0 To 7
  430.             If c = Chr(aL1(j)) Then
  431.                 SB.Append "\" & Chr(aL2(j))
  432.                 p = False
  433.                 Exit For
  434.             End If
  435.         Next
  436.         
  437.         If p Then
  438.             Dim a
  439.             a = AscW(c)
  440.             If a > 31 And a < 127 Then
  441.                 SB.Append c
  442.             ElseIf a > -1 Or a < 65535 Then
  443.                 SB.Append "\u" & String(4 - Len(Hex(a)), "0") & Hex(a)
  444.             End If
  445.         End If
  446.     Next
  447.    
  448.     Encode = SB.toString
  449.     Set SB = Nothing
  450.    
  451. End Function

  452. Private Function multiArray(aBD, iBC, sPS, ByRef sPT)
  453.    
  454.     Dim iDU As Long
  455.     Dim iDL As Long
  456.     Dim i As Long
  457.    
  458.     On Error Resume Next
  459.     iDL = LBound(aBD, iBC)
  460.     iDU = UBound(aBD, iBC)
  461.    
  462.     Dim SB As New cStringBuilder
  463.    
  464.     Dim sPB1, sPB2                                                              ' String PointBuffer1, String PointBuffer2
  465.     If ERR.Number = 9 Then
  466.         sPB1 = sPT & sPS
  467.         For i = 1 To Len(sPB1)
  468.             If i <> 1 Then sPB2 = sPB2 & ","
  469.             sPB2 = sPB2 & Mid(sPB1, i, 1)
  470.         Next
  471.         '        multiArray = multiArray & toString(Eval("aBD(" & sPB2 & ")"))
  472.         SB.Append toString(aBD(sPB2))
  473.     Else
  474.         sPT = sPT & sPS
  475.         SB.Append "["
  476.         For i = iDL To iDU
  477.             SB.Append multiArray(aBD, iBC + 1, i, sPT)
  478.             If i < iDU Then SB.Append ","
  479.         Next
  480.         SB.Append "]"
  481.         sPT = Left(sPT, iBC - 2)
  482.     End If
  483.     ERR.Clear
  484.     multiArray = SB.toString
  485.    
  486.     Set SB = Nothing
  487. End Function

  488. ' Miscellaneous JSON functions

  489. Public Function StringToJSON(st As String) As String
  490.    
  491.     Const FIELD_SEP = "~"
  492.     Const RECORD_SEP = "|"
  493.    
  494.     Dim sFlds As String
  495.     Dim sRecs As New cStringBuilder
  496.     Dim lRecCnt As Long
  497.     Dim lFld As Long
  498.     Dim fld As Variant
  499.     Dim rows As Variant
  500.    
  501.     lRecCnt = 0
  502.     If st = "" Then
  503.         StringToJSON = "null"
  504.     Else
  505.         rows = Split(st, RECORD_SEP)
  506.         For lRecCnt = LBound(rows) To UBound(rows)
  507.             sFlds = ""
  508.             fld = Split(rows(lRecCnt), FIELD_SEP)
  509.             For lFld = LBound(fld) To UBound(fld) Step 2
  510.                 sFlds = (sFlds & IIf(sFlds <> "", ",", "") & """" & fld(lFld) & """:""" & toUnicode(fld(lFld + 1) & "") & """")
  511.             Next                                                                'fld
  512.             sRecs.Append IIf((Trim(sRecs.toString) <> ""), "," & vbCrLf, "") & "{" & sFlds & "}"
  513.         Next                                                                    'rec
  514.         StringToJSON = ("( {""Records"": [" & vbCrLf & sRecs.toString & vbCrLf & "], " & """RecordCount"":""" & lRecCnt & """ } )")
  515.     End If
  516. End Function

  517. Public Function toUnicode(str As String) As String
  518.    
  519.     Dim X As Long
  520.     Dim uStr As New cStringBuilder
  521.     Dim uChrCode As Integer
  522.    
  523.     For X = 1 To Len(str)
  524.         uChrCode = Asc(Mid(str, X, 1))
  525.         Select Case uChrCode
  526.         Case 8:                                                                 ' backspace
  527.             uStr.Append "\b"
  528.         Case 9:                                                                 ' tab
  529.             uStr.Append "\t"
  530.         Case 10:                                                                ' line feed
  531.             uStr.Append "\n"
  532.         Case 12:                                                                ' formfeed
  533.             uStr.Append "\f"
  534.         Case 13:                                                                ' carriage return
  535.             uStr.Append "\r"
  536.         Case 34:                                                                ' quote
  537.             uStr.Append "\"""
  538.         Case 39:                                                                ' apostrophe
  539.             uStr.Append "\'"
  540.         Case 92:                                                                ' backslash
  541.             uStr.Append "\\"
  542.         Case 123, 125:                                                          ' "{" and "}"
  543.             uStr.Append ("\u" & Right("0000" & Hex(uChrCode), 4))
  544.         Case Is < 32, Is > 127:                                                 ' non-ascii characters
  545.             uStr.Append ("\u" & Right("0000" & Hex(uChrCode), 4))
  546.         Case Else
  547.             uStr.Append Chr$(uChrCode)
  548.         End Select
  549.     Next
  550.     toUnicode = uStr.toString
  551.     Exit Function
  552.    
  553. End Function

  554. Private Sub Class_Initialize()
  555.     psErrors = ""
  556. End Sub
复制代码
VTableSubclass.cls
  1. Option Explicit
  2. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
  3. Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, ByRef lpflOldProtect As Long) As Long
  4. Private Const PAGE_EXECUTE_READWRITE As Long = &H40
  5. Private PropRefCount As Long
  6. Private PropVTableCount As Long
  7. Private VTableHeaderPointer As Long
  8. Private VTable() As Long, VTableOld() As Long

  9. Private Sub Class_Terminate()
  10.     If VTableHeaderPointer <> 0 Then Call UnSubclass
  11. End Sub

  12. Public Property Get RefCount() As Long
  13. RefCount = PropRefCount
  14. End Property

  15. Public Sub AddRef()
  16.     PropRefCount = PropRefCount + 1
  17. End Sub

  18. Public Sub Release()
  19.     PropRefCount = PropRefCount - 1
  20. End Sub

  21. Public Sub Subclass(ByVal ObjectPointer As Long, ByVal FirstEntry As Long, ByVal LastEntry As Long, ParamArray NewEntries() As Variant)
  22.     FirstEntry = FirstEntry - 1
  23.     Debug.Assert Not (FirstEntry < 0 Or FirstEntry > LastEntry Or LastEntry < 0 Or VTableHeaderPointer <> 0 Or ObjectPointer = 0)
  24.     CopyMemory VTableHeaderPointer, ByVal ObjectPointer, 4
  25.     PropVTableCount = LastEntry
  26.     ReDim VTable(0 To PropVTableCount)
  27.     ReDim VTableOld(0 To PropVTableCount)
  28.     Dim Entry As Long
  29.     Dim EntryPointer As Long
  30.     Entry = UBound(NewEntries()) + FirstEntry
  31.     If Entry > PropVTableCount Then Entry = PropVTableCount
  32.     EntryPointer = UnsignedAdd(VTableHeaderPointer, FirstEntry * 4)
  33.     For Entry = FirstEntry To Entry
  34.         VTable(Entry) = NewEntries(Entry - FirstEntry)
  35.         If VTable(Entry) <> 0 Then
  36.             Call CreateSubclass(EntryPointer, VTable(Entry), VTableOld(Entry))
  37.         End If
  38.         EntryPointer = UnsignedAdd(EntryPointer, 4)
  39.     Next Entry
  40. End Sub

  41. Public Property Get SubclassEntry(ByVal Entry As Long) As Boolean
  42.     Entry = Entry - 1
  43.     Debug.Assert Entry > -1 And Entry < PropVTableCount And VTableHeaderPointer <> 0
  44.     SubclassEntry = CBool(VTableOld(Entry))
  45. End Property

  46. Public Property Let SubclassEntry(ByVal Entry As Long, ByVal Value As Boolean)
  47.     Entry = Entry - 1
  48.     Dim EntryPointer As Long
  49.     Debug.Assert Entry >= 0 And Entry <= PropVTableCount And VTableHeaderPointer <> 0
  50.     If Me.SubclassEntry(Entry + 1) Xor Value Then
  51.         EntryPointer = UnsignedAdd(VTableHeaderPointer, Entry * 4)
  52.         If Value = True Then
  53.             Call CreateSubclass(EntryPointer, VTable(Entry), VTableOld(Entry))
  54.         Else
  55.             Call CreateSubclass(EntryPointer, VTableOld(Entry), 0)
  56.             VTableOld(Entry) = 0
  57.         End If
  58.     End If
  59. End Property

  60. Public Sub ReSubclass()
  61.     If VTableHeaderPointer <> 0 Then
  62.         Dim i As Long
  63.         For i = 0 To PropVTableCount
  64.             If VTableOld(i) <> 0 Then
  65.                 Call CreateSubclass(UnsignedAdd(VTableHeaderPointer, i * 4), VTableOld(i), 0)
  66.                 VTableOld(i) = 0
  67.             End If
  68.         Next i
  69.         For i = 0 To PropVTableCount
  70.             If VTable(i) <> 0 Then
  71.                 Call CreateSubclass(UnsignedAdd(VTableHeaderPointer, i * 4), VTable(i), VTableOld(i))
  72.             End If
  73.         Next i
  74.     End If
  75. End Sub

  76. Public Sub UnSubclass()
  77.     If VTableHeaderPointer <> 0 Then
  78.         Dim i As Long
  79.         For i = 0 To PropVTableCount
  80.             If VTableOld(i) <> 0 Then
  81.                 Call CreateSubclass(UnsignedAdd(VTableHeaderPointer, i * 4), VTableOld(i), 0)
  82.                 VTableOld(i) = 0
  83.             End If
  84.         Next i
  85.         VTableHeaderPointer = 0
  86.     End If
  87. End Sub

  88. Private Sub CreateSubclass(ByVal EntryPointer As Long, ByVal NewPointer As Long, ByRef OldPointer As Long)
  89.     CopyMemory OldPointer, ByVal EntryPointer, 4
  90.     If OldPointer <> NewPointer Then
  91.         Dim OldProtect As Long
  92.         VirtualProtect EntryPointer, 4, PAGE_EXECUTE_READWRITE, OldProtect
  93.         CopyMemory ByVal EntryPointer, NewPointer, 4
  94.         VirtualProtect EntryPointer, 4, OldProtect, OldProtect
  95.     Else
  96.         ' If you get this Assert then better restart the IDE.
  97.         ' Known reasons:
  98.         ' - End button was pushed.
  99.         ' - Object has been modified while it is subclassed.
  100.         '    Debug.Assert CBool(OldPointer <> NewPointer)
  101.     End If
  102. End Sub
复制代码
ListBoxW.ctl
  1. Option Explicit

  2. #Const ImplementThemedButton = True

  3. #If False Then
  4. Private LstStyleStandard, LstStyleCheckbox, LstStyleOption
  5. Private LstDrawModeNormal, LstDrawModeOwnerDrawFixed, LstDrawModeOwnerDrawVariable
  6. #End If
  7. Public Enum LstStyleConstants
  8.     LstStyleStandard = 0
  9.     LstStyleCheckbox = 1
  10.     LstStyleOption = 2
  11. End Enum
  12. Public Enum LstDrawModeConstants
  13.     LstDrawModeNormal = 0
  14.     LstDrawModeOwnerDrawFixed = 1
  15.     LstDrawModeOwnerDrawVariable = 2
  16. End Enum
  17. Private Type POINTAPI
  18.     X As Long
  19.     Y As Long
  20. End Type
  21. Private Type SIZEAPI
  22.     cx As Long
  23.     cy As Long
  24. End Type
  25. Private Type RECT
  26.     Left As Long
  27.     Top As Long
  28.     Right As Long
  29.     Bottom As Long
  30. End Type
  31. Private Type TEXTMETRIC
  32.     TMHeight As Long
  33.     TMAscent As Long
  34.     TMDescent As Long
  35.     TMInternalLeading As Long
  36.     TMExternalLeading As Long
  37.     TMAveCharWidth As Long
  38.     TMMaxCharWidth As Long
  39.     TMWeight As Long
  40.     TMOverhang As Long
  41.     TMDigitizedAspectX As Long
  42.     TMDigitizedAspectY As Long
  43.     TMFirstChar As Integer
  44.     TMLastChar As Integer
  45.     TMDefaultChar As Integer
  46.     TMBreakChar As Integer
  47.     TMItalic As Byte
  48.     TMUnderlined As Byte
  49.     TMStruckOut As Byte
  50.     TMPitchAndFamily As Byte
  51.     TMCharset As Byte
  52. End Type
  53. Private Type MEASUREITEMSTRUCT
  54.     CtlType As Long
  55.     CtlID As Long
  56.     ItemID As Long
  57.     ItemWidth As Long
  58.     ItemHeight As Long
  59.     ItemData As Long
  60. End Type
  61. Private Type DRAWITEMSTRUCT
  62.     CtlType As Long
  63.     CtlID As Long
  64.     ItemID As Long
  65.     ItemAction As Long
  66.     ItemState As Long
  67.     hWndItem As Long
  68.     hDC As Long
  69.     RCItem As RECT
  70.     ItemData As Long
  71. End Type
  72. Private Type SCROLLINFO
  73.     cbSize As Long
  74.     fMask As Long
  75.     nMin As Long
  76.     nMax As Long
  77.     nPage As Long
  78.     nPos As Long
  79.     nTrackPos As Long
  80. End Type
  81. Public Event Click()
  82. Public Event DblClick()
  83. Public Event Scroll()
  84. Public Event ContextMenu(ByVal X As Single, ByVal Y As Single)
  85. Public Event ItemBeforeCheck(ByVal Item As Long, ByRef Cancel As Boolean)
  86. Public Event ItemCheck(ByVal Item As Long)
  87. Public Event ItemMeasure(ByVal Item As Long, ByRef ItemHeight As Long)
  88. 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)
  89. Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean)
  90. Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean)
  91. Public Event KeyDown(KeyCode As Integer, Shift As Integer)
  92. Public Event KeyUp(KeyCode As Integer, Shift As Integer)
  93. Public Event KeyPress(KeyChar As Integer)
  94. Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  95. Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  96. Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  97. Public Event MouseEnter()
  98. Public Event MouseLeave()
  99. Public Event OLECompleteDrag(Effect As Long)
  100. Public Event OLEDragDrop(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
  101. Public Event OLEDragOver(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
  102. Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean)
  103. Public Event OLESetData(data As DataObject, DataFormat As Integer)
  104. Public Event OLEStartDrag(data As DataObject, AllowedEffects As Long)
  105. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
  106. 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
  107. Private Declare Function LBItemFromPt Lib "comctl32" (ByVal hLB As Long, ByVal PX As Long, ByVal PY As Long, ByVal bAutoScroll As Long) As Long
  108. 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
  109. Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
  110. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  111. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  112. Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
  113. Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
  114. Private Declare Function GetFocus Lib "user32" () As Long
  115. Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
  116. 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
  117. Private Declare Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
  118. Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
  119. Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
  120. Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
  121. Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
  122. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  123. Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorW" (ByVal hInstance As Long, ByVal lpCursorName As Any) As Long
  124. Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
  125. Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
  126. Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
  127. Private Declare Function GetScrollInfo Lib "user32" (ByVal hwnd As Long, ByVal wBar As Long, ByRef lpScrollInfo As SCROLLINFO) As Long
  128. Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As Long
  129. Private Declare Function DragDetect Lib "user32" (ByVal hwnd As Long, ByVal PX As Integer, ByVal PY As Integer) As Long
  130. Private Declare Function ReleaseCapture Lib "user32" () As Long
  131. Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  132. 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
  133. Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsW" (ByVal hDC As Long, ByRef lpMetrics As TEXTMETRIC) As Long
  134. Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As Any, ByVal bErase As Long) As Long
  135. Private Declare Function CreateRectRgnIndirect Lib "gdi32" (ByRef lpRect As RECT) As Long
  136. Private Declare Function ExtSelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long, ByVal fnMode As Long) As Long
  137. 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
  138. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  139. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  140. Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
  141. 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
  142. Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
  143. Private Declare Function SetTextAlign Lib "gdi32" (ByVal hDC As Long, ByVal fMode As Long) As Long
  144. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  145. Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
  146. Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
  147. 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
  148. Private Declare Function DrawFocusRect Lib "user32" (ByVal hDC As Long, ByRef lpRect As RECT) As Long
  149. Private Declare Function DrawFrameControl Lib "user32" (ByVal hDC As Long, ByRef lpRect As RECT, ByVal nCtlType As Long, ByVal nFlags As Long) As Long

  150. #If ImplementThemedButton = True Then

  151. Private Enum UxThemeButtonParts
  152.     BP_PUSHBUTTON = 1
  153.     BP_RADIOBUTTON = 2
  154.     BP_CHECKBOX = 3
  155.     BP_GROUPBOX = 4
  156.     BP_USERBUTTON = 5
  157. End Enum
  158. Private Enum UxThemeCheckBoxStates
  159.     CBS_UNCHECKEDNORMAL = 1
  160.     CBS_UNCHECKEDHOT = 2
  161.     CBS_UNCHECKEDPRESSED = 3
  162.     CBS_UNCHECKEDDISABLED = 4
  163.     CBS_CHECKEDNORMAL = 5
  164.     CBS_CHECKEDHOT = 6
  165.     CBS_CHECKEDPRESSED = 7
  166.     CBS_CHECKEDDISABLED = 8
  167. End Enum
  168. Private Enum UxThemeRadioButtonStates
  169.     RBS_UNCHECKEDNORMAL = 1
  170.     RBS_UNCHECKEDHOT = 2
  171.     RBS_UNCHECKEDPRESSED = 3
  172.     RBS_UNCHECKEDDISABLED = 4
  173.     RBS_CHECKEDNORMAL = 5
  174.     RBS_CHECKEDHOT = 6
  175.     RBS_CHECKEDPRESSED = 7
  176.     RBS_CHECKEDDISABLED = 8
  177. End Enum
  178. Private Declare Function IsThemeBackgroundPartiallyTransparent Lib "uxtheme" (ByVal Theme As Long, iPartId As Long, iStateId As Long) As Long
  179. Private Declare Function DrawThemeParentBackground Lib "uxtheme" (ByVal hwnd As Long, ByVal hDC As Long, ByRef pRect As RECT) As Long
  180. 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
  181. Private Declare Function OpenThemeData Lib "uxtheme" (ByVal hwnd As Long, ByVal pszClassList As Long) As Long
  182. Private Declare Function CloseThemeData Lib "uxtheme" (ByVal Theme As Long) As Long

  183. #End If

  184. Private Const ICC_STANDARD_CLASSES As Long = &H4000
  185. Private Const RDW_UPDATENOW As Long = &H100, RDW_INVALIDATE As Long = &H1, RDW_ERASE As Long = &H4, RDW_ALLCHILDREN As Long = &H80
  186. Private Const GWL_STYLE As Long = (-16)
  187. Private Const CF_UNICODETEXT As Long = 13
  188. Private Const TA_RTLREADING = &H100, TA_RIGHT As Long = &H2
  189. Private Const WS_VISIBLE As Long = &H10000000
  190. Private Const WS_CHILD As Long = &H40000000
  191. Private Const WS_EX_RTLREADING As Long = &H2000, WS_EX_RIGHT As Long = &H1000, WS_EX_LEFTSCROLLBAR As Long = &H4000
  192. Private Const SW_HIDE As Long = &H0
  193. 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
  194. Private Const WM_MOUSEWHEEL As Long = &H20A
  195. Private Const WM_SETFOCUS As Long = &H7
  196. Private Const WM_KILLFOCUS As Long = &H8
  197. Private Const WM_KEYDOWN As Long = &H100
  198. Private Const WM_KEYUP As Long = &H101
  199. Private Const WM_CHAR As Long = &H102
  200. Private Const WM_SYSKEYDOWN As Long = &H104
  201. Private Const WM_SYSKEYUP As Long = &H105
  202. Private Const WM_UNICHAR As Long = &H109, UNICODE_NOCHAR As Long = &HFFFF&
  203. Private Const WM_IME_CHAR As Long = &H286
  204. Private Const WM_LBUTTONDOWN As Long = &H201
  205. Private Const WM_LBUTTONUP As Long = &H202
  206. Private Const WM_MBUTTONDOWN As Long = &H207
  207. Private Const WM_MBUTTONUP As Long = &H208
  208. Private Const WM_RBUTTONDOWN As Long = &H204
  209. Private Const WM_RBUTTONUP As Long = &H205
  210. Private Const WM_MOUSEMOVE As Long = &H200
  211. Private Const WM_MOUSELEAVE As Long = &H2A3
  212. Private Const WM_COMMAND As Long = &H111
  213. Private Const WM_SETREDRAW As Long = &HB
  214. Private Const WM_CONTEXTMENU As Long = &H7B
  215. Private Const WM_MEASUREITEM As Long = &H2C
  216. 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
  217. Private Const WM_DESTROY As Long = &H2
  218. Private Const WM_NCDESTROY As Long = &H82
  219. Private Const WM_STYLECHANGED As Long = &H7D
  220. Private Const WM_SETFONT As Long = &H30
  221. Private Const WM_SETCURSOR As Long = &H20, HTCLIENT As Long = 1
  222. Private Const WM_PAINT As Long = &HF
  223. Private Const WS_HSCROLL As Long = &H100000
  224. Private Const WS_VSCROLL As Long = &H200000
  225. Private Const WM_VSCROLL As Long = &H115
  226. Private Const WM_HSCROLL As Long = &H114
  227. Private Const SB_HORZ As Long = 0
  228. Private Const SB_VERT As Long = 1
  229. Private Const SB_THUMBPOSITION = 4, SB_THUMBTRACK As Long = 5
  230. Private Const SB_LINELEFT As Long = 0, SB_LINERIGHT As Long = 1
  231. Private Const SB_LINEUP As Long = 0, SB_LINEDOWN As Long = 1
  232. Private Const SIF_POS As Long = &H4
  233. Private Const SIF_TRACKPOS As Long = &H10
  234. Private Const RGN_COPY As Long = 5
  235. 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
  236. Private Const LB_ERR As Long = (-1)
  237. Private Const LB_ADDSTRING As Long = &H180
  238. Private Const LB_INSERTSTRING As Long = &H181
  239. Private Const LB_DELETESTRING As Long = &H182
  240. Private Const LB_SELITEMRANGEEX As Long = &H183
  241. Private Const LB_RESETCONTENT As Long = &H184
  242. Private Const LB_SETSEL As Long = &H185
  243. Private Const LB_SETCURSEL As Long = &H186
  244. Private Const LB_GETSEL As Long = &H187
  245. Private Const LB_GETCURSEL As Long = &H188
  246. Private Const LB_GETTEXT As Long = &H189
  247. Private Const LB_GETTEXTLEN As Long = &H18A
  248. Private Const LB_GETCOUNT As Long = &H18B
  249. Private Const LB_SELECTSTRING As Long = &H18C
  250. Private Const LB_DIR As Long = &H18D
  251. Private Const LB_GETTOPINDEX As Long = &H18E
  252. Private Const LB_FINDSTRING As Long = &H18F
  253. Private Const LB_GETSELCOUNT As Long = &H190
  254. Private Const LB_GETSELITEMS As Long = &H191
  255. Private Const LB_SETTABSTOPS As Long = &H192
  256. Private Const LB_GETHORIZONTALEXTENT As Long = &H193
  257. Private Const LB_SETHORIZONTALEXTENT As Long = &H194
  258. Private Const LB_SETCOLUMNWIDTH As Long = &H195
  259. Private Const LB_ADDFILE As Long = &H196
  260. Private Const LB_SETTOPINDEX As Long = &H197
  261. Private Const LB_GETITEMRECT As Long = &H198
  262. Private Const LB_GETITEMDATA As Long = &H199
  263. Private Const LB_SETITEMDATA As Long = &H19A
  264. Private Const LB_SELITEMRANGE As Long = &H19B                                   ' 16 bit
  265. Private Const LB_SETANCHORINDEX As Long = &H19C
  266. Private Const LB_GETANCHORINDEX As Long = &H19D
  267. Private Const LB_SETCARETINDEX As Long = &H19E
  268. Private Const LB_GETCARETINDEX As Long = &H19F
  269. Private Const LB_SETITEMHEIGHT As Long = &H1A0
  270. Private Const LB_GETITEMHEIGHT As Long = &H1A1
  271. Private Const LB_FINDSTRINGEXACT As Long = &H1A2
  272. Private Const LB_SETLOCALE As Long = &H1A5
  273. Private Const LB_GETLOCALE As Long = &H1A6
  274. Private Const LB_SETCOUNT As Long = &H1A7
  275. Private Const LB_INITSTORAGE As Long = &H1A8
  276. Private Const LB_ITEMFROMPOINT As Long = &H1A9                                  ' 16 bit
  277. Private Const LB_GETLISTBOXINFO As Long = &H1B2
  278. Private Const LBS_NOTIFY As Long = &H1
  279. Private Const LBS_SORT As Long = &H2
  280. Private Const LBS_NOREDRAW As Long = &H4
  281. Private Const LBS_MULTIPLESEL As Long = &H8
  282. Private Const LBS_OWNERDRAWFIXED As Long = &H10
  283. Private Const LBS_OWNERDRAWVARIABLE As Long = &H20
  284. Private Const LBS_HASSTRINGS As Long = &H40
  285. Private Const LBS_USETABSTOPS As Long = &H80
  286. Private Const LBS_NOINTEGRALHEIGHT As Long = &H100
  287. Private Const LBS_MULTICOLUMN As Long = &H200
  288. Private Const LBS_WANTKEYBOARDINPUT As Long = &H400
  289. Private Const LBS_EXTENDEDSEL As Long = &H800
  290. Private Const LBS_DISABLENOSCROLL As Long = &H1000
  291. Private Const LBS_NODATA As Long = &H2000
  292. Private Const LBS_NOSEL As Long = &H4000
  293. Private Const LBN_ERRSPACE As Long = (-2)
  294. Private Const LBN_SELCHANGE As Long = 1
  295. Private Const LBN_DBLCLK As Long = 2
  296. Private Const LBN_SELCANCEL As Long = 3
  297. Private Const LBN_SETFOCUS As Long = 4
  298. Private Const LBN_KILLFOCUS As Long = 5
  299. Implements ISubclass
  300. Implements OLEGuids.IObjectSafety
  301. Implements OLEGuids.IOleInPlaceActiveObjectVB
  302. Implements OLEGuids.IPerPropertyBrowsingVB
  303. Private ListBoxHandle As Long
  304. Private ListBoxFontHandle As Long
  305. Private ListBoxCharCodeCache As Long
  306. Private ListBoxMouseOver As Boolean
  307. Private ListBoxDesignMode As Boolean, ListBoxTopDesignMode As Boolean
  308. Private ListBoxNewIndex As Long
  309. Private ListBoxDragIndexBuffer As Long, ListBoxDragIndex As Long
  310. Private ListBoxTopIndex As Long
  311. Private ListBoxInsertMark As Long, ListBoxInsertMarkAfter As Boolean
  312. Private ListBoxItemCheckedCount As Long
  313. Private ListBoxItemChecked() As Byte, ListBoxOptionIndex As Long
  314. Private ListBoxStateImageSize As Long
  315. Private DispIDMousePointer As Long
  316. Private WithEvents PropFont As StdFont
  317. Private PropVisualStyles As Boolean
  318. Private PropOLEDragMode As VBRUN.OLEDragConstants
  319. Private PropOLEDragDropScroll As Boolean
  320. Private PropMousePointer As Integer, PropMouseIcon As IPictureDisp
  321. Private PropMouseTrack As Boolean
  322. Private PropRightToLeft As Boolean
  323. Private PropRightToLeftMode As CCRightToLeftModeConstants
  324. Private PropRedraw As Boolean
  325. Private PropBorderStyle As CCBorderStyleConstants
  326. Private PropMultiColumn As Boolean
  327. Private PropSorted As Boolean
  328. Private PropIntegralHeight As Boolean
  329. Private PropAllowSelection As Boolean
  330. Private PropMultiSelect As VBRUN.MultiSelectConstants
  331. Private PropHorizontalExtent As Long
  332. Private PropUseTabStops As Boolean
  333. Private PropStyle As LstStyleConstants
  334. Private PropDisableNoScroll As Boolean
  335. Private PropDrawMode As LstDrawModeConstants
  336. Private PropInsertMarkColor As OLE_COLOR
  337. Private PropScrollTrack As Boolean

  338. Private Sub IObjectSafety_GetInterfaceSafetyOptions(ByRef riid As OLEGuids.OLECLSID, ByRef pdwSupportedOptions As Long, ByRef pdwEnabledOptions As Long)
  339.     Const INTERFACESAFE_FOR_UNTRUSTED_CALLER As Long = &H1, INTERFACESAFE_FOR_UNTRUSTED_DATA As Long = &H2
  340.     pdwSupportedOptions = INTERFACESAFE_FOR_UNTRUSTED_CALLER Or INTERFACESAFE_FOR_UNTRUSTED_DATA
  341.     pdwEnabledOptions = INTERFACESAFE_FOR_UNTRUSTED_CALLER Or INTERFACESAFE_FOR_UNTRUSTED_DATA
  342. End Sub

  343. Private Sub IObjectSafety_SetInterfaceSafetyOptions(ByRef riid As OLEGuids.OLECLSID, ByVal dwOptionsSetMask As Long, ByVal dwEnabledOptions As Long)
  344. End Sub

  345. 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)
  346.     If wMsg = WM_KEYDOWN Or wMsg = WM_KEYUP Then
  347.         Dim KeyCode As Integer, IsInputKey As Boolean
  348.         KeyCode = wParam And &HFF&
  349.         If wMsg = WM_KEYDOWN Then
  350.             RaiseEvent PreviewKeyDown(KeyCode, IsInputKey)
  351.         ElseIf wMsg = WM_KEYUP Then
  352.             RaiseEvent PreviewKeyUp(KeyCode, IsInputKey)
  353.         End If
  354.         Select Case KeyCode
  355.         Case vbKeyUp, vbKeyDown, vbKeyLeft, vbKeyRight, vbKeyPageDown, vbKeyPageUp, vbKeyHome, vbKeyEnd
  356.             If ListBoxHandle <> 0 Then
  357.                 SendMessage ListBoxHandle, wMsg, wParam, ByVal lParam
  358.                 Handled = True
  359.             End If
  360.         Case vbKeyTab, vbKeyReturn, vbKeyEscape
  361.             If IsInputKey = True Then
  362.                 If ListBoxHandle <> 0 Then
  363.                     SendMessage ListBoxHandle, wMsg, wParam, ByVal lParam
  364.                     Handled = True
  365.                 End If
  366.             End If
  367.         End Select
  368.     End If
  369. End Sub

  370. Private Sub IPerPropertyBrowsingVB_GetDisplayString(ByRef Handled As Boolean, ByVal DispID As Long, ByRef DisplayName As String)
  371.     If DispID = DispIDMousePointer Then
  372.         Call ComCtlsIPPBSetDisplayStringMousePointer(PropMousePointer, DisplayName)
  373.         Handled = True
  374.     End If
  375. End Sub

  376. Private Sub IPerPropertyBrowsingVB_GetPredefinedStrings(ByRef Handled As Boolean, ByVal DispID As Long, ByRef StringsOut() As String, ByRef CookiesOut() As Long)
  377.     If DispID = DispIDMousePointer Then
  378.         Call ComCtlsIPPBSetPredefinedStringsMousePointer(StringsOut(), CookiesOut())
  379.         Handled = True
  380.     End If
  381. End Sub

  382. Private Sub IPerPropertyBrowsingVB_GetPredefinedValue(ByRef Handled As Boolean, ByVal DispID As Long, ByVal Cookie As Long, ByRef Value As Variant)
  383.     If DispID = DispIDMousePointer Then
  384.         Value = Cookie
  385.         Handled = True
  386.     End If
  387. End Sub

  388. Private Sub UserControl_Initialize()
  389.     Call ComCtlsLoadShellMod
  390.     Call ComCtlsInitCC(ICC_STANDARD_CLASSES)
  391.     Call SetVTableSubclass(Me, VTableInterfaceInPlaceActiveObject)
  392.     Call SetVTableSubclass(Me, VTableInterfacePerPropertyBrowsing)
  393.     ReDim ListBoxItemChecked(0) As Byte
  394.     ListBoxStateImageSize = (15 * PixelsPerDIP_X())
  395. End Sub

  396. Private Sub UserControl_InitProperties()
  397.     If DispIDMousePointer = 0 Then DispIDMousePointer = GetDispID(Me, "MousePointer")
  398.     On Error Resume Next
  399.     ListBoxDesignMode = Not Ambient.UserMode
  400.     ListBoxTopDesignMode = Not GetTopUserControl(Me).Ambient.UserMode
  401.     On Error GoTo 0
  402.     Set PropFont = Ambient.Font
  403.     PropVisualStyles = True
  404.     PropOLEDragMode = vbOLEDragManual
  405.     PropOLEDragDropScroll = True
  406.     Me.OLEDropMode = vbOLEDropNone
  407.     PropMousePointer = 0: Set PropMouseIcon = Nothing
  408.     PropMouseTrack = False
  409.     PropRightToLeft = Ambient.RightToLeft
  410.     PropRightToLeftMode = CCRightToLeftModeVBAME
  411.     If PropRightToLeft = True Then Me.RightToLeft = True
  412.     PropRedraw = True
  413.     PropBorderStyle = CCBorderStyleSunken
  414.     PropSorted = False
  415.     PropIntegralHeight = True
  416.     PropAllowSelection = True
  417.     PropMultiSelect = vbMultiSelectNone
  418.     PropHorizontalExtent = 0
  419.     PropUseTabStops = True
  420.     PropStyle = vbListBoxStandard
  421.     PropDisableNoScroll = False
  422.     PropDrawMode = LstDrawModeNormal
  423.     PropInsertMarkColor = vbBlack
  424.     PropScrollTrack = True
  425.     Call CreateListBox
  426. End Sub

  427. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  428.     If DispIDMousePointer = 0 Then DispIDMousePointer = GetDispID(Me, "MousePointer")
  429.     On Error Resume Next
  430.     ListBoxDesignMode = Not Ambient.UserMode
  431.     ListBoxTopDesignMode = Not GetTopUserControl(Me).Ambient.UserMode
  432.     On Error GoTo 0
  433.     With PropBag
  434.         Set PropFont = .ReadProperty("Font", Nothing)
  435.         PropVisualStyles = .ReadProperty("VisualStyles", True)
  436.         Me.BackColor = .ReadProperty("BackColor", vbButtonFace)
  437.         Me.ForeColor = .ReadProperty("ForeColor", vbButtonText)
  438.         Me.Enabled = .ReadProperty("Enabled", True)
  439.         PropOLEDragMode = .ReadProperty("OLEDragMode", vbOLEDragManual)
  440.         PropOLEDragDropScroll = .ReadProperty("OLEDragDropScroll", True)
  441.         Me.OLEDropMode = .ReadProperty("OLEDropMode", vbOLEDropNone)
  442.         PropMousePointer = .ReadProperty("MousePointer", 0)
  443.         Set PropMouseIcon = .ReadProperty("MouseIcon", Nothing)
  444.         PropMouseTrack = .ReadProperty("MouseTrack", False)
  445.         PropRightToLeft = .ReadProperty("RightToLeft", False)
  446.         PropRightToLeftMode = .ReadProperty("RightToLeftMode", CCRightToLeftModeVBAME)
  447.         If PropRightToLeft = True Then Me.RightToLeft = True
  448.         PropRedraw = .ReadProperty("Redraw", True)
  449.         PropBorderStyle = .ReadProperty("BorderStyle", CCBorderStyleSunken)
  450.         PropMultiColumn = .ReadProperty("MultiColumn", False)
  451.         PropSorted = .ReadProperty("Sorted", False)
  452.         PropIntegralHeight = .ReadProperty("IntegralHeight", True)
  453.         PropAllowSelection = .ReadProperty("AllowSelection", True)
  454.         PropMultiSelect = .ReadProperty("MultiSelect", vbMultiSelectNone)
  455.         PropHorizontalExtent = .ReadProperty("HorizontalExtent", 0)
  456.         PropUseTabStops = .ReadProperty("UseTabStops", True)
  457.         PropStyle = .ReadProperty("Style", vbListBoxStandard)
  458.         PropDisableNoScroll = .ReadProperty("DisableNoScroll", False)
  459.         PropDrawMode = .ReadProperty("DrawMode", LstDrawModeNormal)
  460.         PropInsertMarkColor = .ReadProperty("InsertMarkColor", vbBlack)
  461.         PropScrollTrack = .ReadProperty("ScrollTrack", True)
  462.     End With
  463.     Call CreateListBox
  464. End Sub

  465. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  466.     With PropBag
  467.         .WriteProperty "Font", IIf(OLEFontIsEqual(PropFont, Ambient.Font) = False, PropFont, Nothing), Nothing
  468.         .WriteProperty "VisualStyles", PropVisualStyles, True
  469.         .WriteProperty "BackColor", Me.BackColor, vbButtonFace
  470.         .WriteProperty "ForeColor", Me.ForeColor, vbButtonText
  471.         .WriteProperty "Enabled", Me.Enabled, True
  472.         .WriteProperty "OLEDragMode", PropOLEDragMode, vbOLEDragManual
  473.         .WriteProperty "OLEDragDropScroll", PropOLEDragDropScroll, True
  474.         .WriteProperty "OLEDropMode", Me.OLEDropMode, vbOLEDropNone
  475.         .WriteProperty "MousePointer", PropMousePointer, 0
  476.         .WriteProperty "MouseIcon", PropMouseIcon, Nothing
  477.         .WriteProperty "MouseTrack", PropMouseTrack, False
  478.         .WriteProperty "RightToLeft", PropRightToLeft, False
  479.         .WriteProperty "RightToLeftMode", PropRightToLeftMode, CCRightToLeftModeVBAME
  480.         .WriteProperty "Redraw", PropRedraw, True
  481.         .WriteProperty "BorderStyle", PropBorderStyle, CCBorderStyleSunken
  482.         .WriteProperty "MultiColumn", PropMultiColumn, False
  483.         .WriteProperty "Sorted", PropSorted, False
  484.         .WriteProperty "IntegralHeight", PropIntegralHeight, True
  485.         .WriteProperty "AllowSelection", PropAllowSelection, True
  486.         .WriteProperty "MultiSelect", PropMultiSelect, vbMultiSelectNone
  487.         .WriteProperty "HorizontalExtent", PropHorizontalExtent, 0
  488.         .WriteProperty "UseTabStops", PropUseTabStops, True
  489.         .WriteProperty "Style", PropStyle, vbListBoxStandard
  490.         .WriteProperty "DisableNoScroll", PropDisableNoScroll, False
  491.         .WriteProperty "DrawMode", PropDrawMode, LstDrawModeNormal
  492.         .WriteProperty "InsertMarkColor", PropInsertMarkColor, vbBlack
  493.         .WriteProperty "ScrollTrack", PropScrollTrack, True
  494.     End With
  495. End Sub

  496. Private Sub UserControl_OLECompleteDrag(Effect As Long)
  497.     RaiseEvent OLECompleteDrag(Effect)
  498.     ListBoxDragIndex = 0
  499. End Sub

  500. Private Sub UserControl_OLEDragDrop(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
  501.     RaiseEvent OLEDragDrop(data, Effect, Button, Shift, UserControl.ScaleX(X, vbPixels, vbContainerPosition), UserControl.ScaleY(Y, vbPixels, vbContainerPosition))
  502. End Sub

  503. 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)
  504.     RaiseEvent OLEDragOver(data, Effect, Button, Shift, UserControl.ScaleX(X, vbPixels, vbContainerPosition), UserControl.ScaleY(Y, vbPixels, vbContainerPosition), State)
  505.     If ListBoxHandle <> 0 Then
  506.         If State = vbOver And Not Effect = vbDropEffectNone Then
  507.             If PropOLEDragDropScroll = True Then
  508.                 Dim RC As RECT
  509.                 GetWindowRect ListBoxHandle, RC
  510.                 Dim dwStyle As Long
  511.                 dwStyle = GetWindowLong(ListBoxHandle, GWL_STYLE)
  512.                 If (dwStyle And WS_HSCROLL) = WS_HSCROLL Then
  513.                     If Abs(X) < (16 * PixelsPerDIP_X()) Then
  514.                         SendMessage ListBoxHandle, WM_HSCROLL, SB_LINELEFT, ByVal 0&
  515.                     ElseIf Abs(X - (RC.Right - RC.Left)) < (16 * PixelsPerDIP_X()) Then
  516.                         SendMessage ListBoxHandle, WM_HSCROLL, SB_LINERIGHT, ByVal 0&
  517.                     End If
  518.                 End If
  519.                 If (dwStyle And WS_VSCROLL) = WS_VSCROLL Then
  520.                     If Abs(Y) < (16 * PixelsPerDIP_Y()) Then
  521.                         SendMessage ListBoxHandle, WM_VSCROLL, SB_LINEUP, ByVal 0&
  522.                     ElseIf Abs(Y - (RC.Bottom - RC.Top)) < (16 * PixelsPerDIP_Y()) Then
  523.                         SendMessage ListBoxHandle, WM_VSCROLL, SB_LINEDOWN, ByVal 0&
  524.                     End If
  525.                 End If
  526.             End If
  527.         End If
  528.     End If
  529. End Sub

  530. Private Sub UserControl_OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean)
  531.     RaiseEvent OLEGiveFeedback(Effect, DefaultCursors)
  532. End Sub

  533. Private Sub UserControl_OLESetData(data As DataObject, DataFormat As Integer)
  534.     RaiseEvent OLESetData(data, DataFormat)
  535. End Sub

  536. Private Sub UserControl_OLEStartDrag(data As DataObject, AllowedEffects As Long)
  537.     If ListBoxDragIndex > 0 Then
  538.         If PropOLEDragMode = vbOLEDragAutomatic Then
  539.             Dim SelIndices As Collection, Text As String
  540.             Set SelIndices = Me.SelectedIndices
  541.             With SelIndices
  542.                 If .Count > 0 Then
  543.                     Dim Item As Variant, i As Long
  544.                     For Each Item In SelIndices
  545.                         i = i + 1
  546.                         Text = Text & Me.List(Item) & IIf(i < .Count, vbCrLf, vbNullString)
  547.                     Next Item
  548.                 End If
  549.             End With
  550.             data.SetData StrToVar(Text & vbNullChar), CF_UNICODETEXT
  551.             data.SetData StrToVar(Text), vbCFText
  552.             AllowedEffects = vbDropEffectCopy
  553.         End If
  554.     ElseIf ListBoxHandle <> 0 Then
  555.         Dim p As POINTAPI
  556.         GetCursorPos p
  557.         ListBoxDragIndex = LBItemFromPt(ListBoxHandle, p.X, p.Y, 0) + 1
  558.     End If
  559.     RaiseEvent OLEStartDrag(data, AllowedEffects)
  560.     If AllowedEffects = vbDropEffectNone Then ListBoxDragIndex = 0
  561. End Sub

  562. Public Sub OLEDrag()
  563.     If ListBoxDragIndex > 0 Then Exit Sub
  564.     If ListBoxDragIndexBuffer > 0 Then ListBoxDragIndex = ListBoxDragIndexBuffer
  565.     UserControl.OLEDrag
  566. End Sub

  567. Private Sub UserControl_AmbientChanged(PropertyName As String)
  568.     If ListBoxDesignMode = True And PropertyName = "DisplayName" Then
  569.         If ListBoxHandle <> 0 Then
  570.             If SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&) > 0 Then
  571.                 Dim Buffer As String
  572.                 Buffer = Ambient.DisplayName
  573.                 SendMessage ListBoxHandle, LB_RESETCONTENT, 0, ByVal 0&
  574.                 SendMessage ListBoxHandle, LB_ADDSTRING, 0, ByVal StrPtr(Buffer)
  575.                 SendMessage ListBoxHandle, LB_SETCURSEL, -1, ByVal 0&
  576.             End If
  577.         End If
  578.     End If
  579. End Sub

  580. Private Sub UserControl_Resize()
  581.     Static InProc As Boolean
  582.     If InProc = True Then Exit Sub
  583.     InProc = True
  584.     With UserControl
  585.         If DPICorrectionFactor() <> 1 Then Call SyncObjectRectsToContainer(Me)
  586.         If ListBoxHandle = 0 Then InProc = False: Exit Sub
  587.         Dim WndRect As RECT
  588.         MoveWindow ListBoxHandle, 0, 0, .ScaleWidth, .ScaleHeight, 1
  589.         If PropIntegralHeight = True Then
  590.             GetWindowRect ListBoxHandle, WndRect
  591.             .Extender.Height = .ScaleY((WndRect.Bottom - WndRect.Top), vbPixels, vbContainerSize)
  592.         End If
  593.         If DPICorrectionFactor() <> 1 Then Call SyncObjectRectsToContainer(Me)
  594.     End With
  595.     InProc = False
  596. End Sub

  597. Private Sub UserControl_Terminate()
  598.     Call RemoveVTableSubclass(Me, VTableInterfaceInPlaceActiveObject)
  599.     Call RemoveVTableSubclass(Me, VTableInterfacePerPropertyBrowsing)
  600.     Call DestroyListBox
  601.     Call ComCtlsReleaseShellMod
  602. End Sub

  603. Public Property Get Name() As String
  604. Name = Ambient.DisplayName
  605. End Property

  606. Public Property Get Tag() As String
  607.     Tag = Extender.Tag
  608. End Property

  609. Public Property Let Tag(ByVal Value As String)
  610.     Extender.Tag = Value
  611. End Property

  612. Public Property Get Parent() As Object
  613. Set Parent = UserControl.Parent
  614. End Property

  615. Public Property Get Container() As Object
  616.     Set Container = Extender.Container
  617. End Property

  618. Public Property Set Container(ByVal Value As Object)
  619.     Set Extender.Container = Value
  620. End Property

  621. Public Property Get Left() As Single
  622.     Left = Extender.Left
  623. End Property

  624. Public Property Let Left(ByVal Value As Single)
  625.     Extender.Left = Value
  626. End Property

  627. Public Property Get Top() As Single
  628.     Top = Extender.Top
  629. End Property

  630. Public Property Let Top(ByVal Value As Single)
  631.     Extender.Top = Value
  632. End Property

  633. Public Property Get Width() As Single
  634.     Width = Extender.Width
  635. End Property

  636. Public Property Let Width(ByVal Value As Single)
  637.     Extender.Width = Value
  638. End Property

  639. Public Property Get Height() As Single
  640.     Height = Extender.Height
  641. End Property

  642. Public Property Let Height(ByVal Value As Single)
  643.     Extender.Height = Value
  644. End Property

  645. Public Property Get Visible() As Boolean
  646.     Visible = Extender.Visible
  647. End Property

  648. Public Property Let Visible(ByVal Value As Boolean)
  649.     Extender.Visible = Value
  650. End Property

  651. Public Property Get ToolTipText() As String
  652.     ToolTipText = Extender.ToolTipText
  653. End Property

  654. Public Property Let ToolTipText(ByVal Value As String)
  655.     Extender.ToolTipText = Value
  656. End Property

  657. Public Property Get HelpContextID() As Long
  658.     HelpContextID = Extender.HelpContextID
  659. End Property

  660. Public Property Let HelpContextID(ByVal Value As Long)
  661.     Extender.HelpContextID = Value
  662. End Property

  663. Public Property Get WhatsThisHelpID() As Long
  664.     WhatsThisHelpID = Extender.WhatsThisHelpID
  665. End Property

  666. Public Property Let WhatsThisHelpID(ByVal Value As Long)
  667.     Extender.WhatsThisHelpID = Value
  668. End Property

  669. Public Property Get DragIcon() As IPictureDisp
  670.     Set DragIcon = Extender.DragIcon
  671. End Property

  672. Public Property Let DragIcon(ByVal Value As IPictureDisp)
  673.     Extender.DragIcon = Value
  674. End Property

  675. Public Property Set DragIcon(ByVal Value As IPictureDisp)
  676. Set Extender.DragIcon = Value
  677. End Property

  678. Public Property Get DragMode() As Integer
  679.     DragMode = Extender.DragMode
  680. End Property

  681. Public Property Let DragMode(ByVal Value As Integer)
  682.     Extender.DragMode = Value
  683. End Property

  684. Public Sub Drag(Optional ByRef Action As Variant)
  685.     If IsMissing(Action) Then Extender.Drag Else Extender.Drag Action
  686. End Sub

  687. Public Sub SetFocus()
  688.     Extender.SetFocus
  689. End Sub

  690. Public Sub ZOrder(Optional ByRef Position As Variant)
  691.     If IsMissing(Position) Then Extender.ZOrder Else Extender.ZOrder Position
  692. End Sub

  693. Public Property Get hwnd() As Long
  694. hwnd = ListBoxHandle
  695. End Property

  696. Public Property Get hWndUserControl() As Long
  697. hWndUserControl = UserControl.hwnd
  698. End Property

  699. Public Property Get Font() As StdFont
  700.     Set Font = PropFont
  701. End Property

  702. Public Property Let Font(ByVal NewFont As StdFont)
  703.     Set Me.Font = NewFont
  704. End Property

  705. Public Property Set Font(ByVal NewFont As StdFont)
  706. If NewFont Is Nothing Then Set NewFont = Ambient.Font
  707. Dim OldFontHandle As Long
  708. Set PropFont = NewFont
  709. OldFontHandle = ListBoxFontHandle
  710. ListBoxFontHandle = CreateGDIFontFromOLEFont(PropFont)
  711. If ListBoxHandle <> 0 Then SendMessage ListBoxHandle, WM_SETFONT, ListBoxFontHandle, ByVal 1&
  712. If OldFontHandle <> 0 Then DeleteObject OldFontHandle
  713. If PropStyle <> LstStyleStandard And ListBoxHandle <> 0 Then
  714.     Dim hDCScreen As Long
  715.     hDCScreen = GetDC(0)
  716.     If hDCScreen <> 0 Then
  717.         Dim TM As TEXTMETRIC, hFontOld As Long
  718.         If ListBoxFontHandle <> 0 Then hFontOld = SelectObject(hDCScreen, ListBoxFontHandle)
  719.         If GetTextMetrics(hDCScreen, TM) <> 0 Then
  720.             If TM.TMHeight < ListBoxStateImageSize Then TM.TMHeight = ListBoxStateImageSize
  721.             SendMessage ListBoxHandle, LB_SETITEMHEIGHT, 0, ByVal TM.TMHeight
  722.             If PropIntegralHeight = True Then
  723.                 MoveWindow ListBoxHandle, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight + 1, 0
  724.                 MoveWindow ListBoxHandle, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight, 0
  725.             End If
  726.         End If
  727.         If hFontOld <> 0 Then SelectObject hDCScreen, hFontOld
  728.         ReleaseDC 0, hDCScreen
  729.     End If
  730. End If
  731. Call UserControl_Resize
  732. UserControl.PropertyChanged "Font"
  733. End Property

  734. Private Sub PropFont_FontChanged(ByVal PropertyName As String)
  735.     Dim OldFontHandle As Long
  736.     OldFontHandle = ListBoxFontHandle
  737.     ListBoxFontHandle = CreateGDIFontFromOLEFont(PropFont)
  738.     If ListBoxHandle <> 0 Then SendMessage ListBoxHandle, WM_SETFONT, ListBoxFontHandle, ByVal 1&
  739.     If OldFontHandle <> 0 Then DeleteObject OldFontHandle
  740.     If PropStyle <> LstStyleStandard And ListBoxHandle <> 0 Then
  741.         Dim hDCScreen As Long
  742.         hDCScreen = GetDC(0)
  743.         If hDCScreen <> 0 Then
  744.             Dim TM As TEXTMETRIC, hFontOld As Long
  745.             If ListBoxFontHandle <> 0 Then hFontOld = SelectObject(hDCScreen, ListBoxFontHandle)
  746.             If GetTextMetrics(hDCScreen, TM) <> 0 Then
  747.                 If TM.TMHeight < ListBoxStateImageSize Then TM.TMHeight = ListBoxStateImageSize
  748.                 SendMessage ListBoxHandle, LB_SETITEMHEIGHT, 0, ByVal TM.TMHeight
  749.                 If PropIntegralHeight = True Then
  750.                     MoveWindow ListBoxHandle, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight + 1, 0
  751.                     MoveWindow ListBoxHandle, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight, 0
  752.                 End If
  753.             End If
  754.             If hFontOld <> 0 Then SelectObject hDCScreen, hFontOld
  755.             ReleaseDC 0, hDCScreen
  756.         End If
  757.     End If
  758.     Call UserControl_Resize
  759.     UserControl.PropertyChanged "Font"
  760. End Sub

  761. Public Property Get VisualStyles() As Boolean
  762.     VisualStyles = PropVisualStyles
  763. End Property

  764. Public Property Let VisualStyles(ByVal Value As Boolean)
  765.     PropVisualStyles = Value
  766.     If ListBoxHandle <> 0 And EnabledVisualStyles() = True Then
  767.         If PropVisualStyles = True Then
  768.             ActivateVisualStyles ListBoxHandle
  769.         Else
  770.             RemoveVisualStyles ListBoxHandle
  771.         End If
  772.         Me.Refresh
  773.     End If
  774.     UserControl.PropertyChanged "VisualStyles"
  775. End Property

  776. Public Property Get BackColor() As OLE_COLOR
  777.     BackColor = UserControl.BackColor
  778. End Property

  779. Public Property Let BackColor(ByVal Value As OLE_COLOR)
  780.     UserControl.BackColor = Value
  781.     Me.Refresh
  782.     UserControl.PropertyChanged "BackColor"
  783. End Property

  784. Public Property Get ForeColor() As OLE_COLOR
  785.     ForeColor = UserControl.ForeColor
  786. End Property

  787. Public Property Let ForeColor(ByVal Value As OLE_COLOR)
  788.     UserControl.ForeColor = Value
  789.     Me.Refresh
  790.     UserControl.PropertyChanged "ForeColor"
  791. End Property

  792. Public Property Get Enabled() As Boolean
  793.     Enabled = UserControl.Enabled
  794. End Property

  795. Public Property Let Enabled(ByVal Value As Boolean)
  796.     UserControl.Enabled = Value
  797.     If ListBoxHandle <> 0 Then EnableWindow ListBoxHandle, IIf(Value = True, 1, 0)
  798.     UserControl.PropertyChanged "Enabled"
  799. End Property

  800. Public Property Get OLEDragMode() As VBRUN.OLEDragConstants
  801.     OLEDragMode = PropOLEDragMode
  802. End Property

  803. Public Property Let OLEDragMode(ByVal Value As VBRUN.OLEDragConstants)
  804.     Select Case Value
  805.     Case vbOLEDragManual, vbOLEDragAutomatic
  806.         PropOLEDragMode = Value
  807.     Case Else
  808.         ERR.Raise 380
  809.     End Select
  810.     UserControl.PropertyChanged "OLEDragMode"
  811. End Property

  812. Public Property Get OLEDragDropScroll() As Boolean
  813.     OLEDragDropScroll = PropOLEDragDropScroll
  814. End Property

  815. Public Property Let OLEDragDropScroll(ByVal Value As Boolean)
  816.     PropOLEDragDropScroll = Value
  817.     UserControl.PropertyChanged "OLEDragDropScroll"
  818. End Property

  819. Public Property Get OLEDropMode() As OLEDropModeConstants
  820.     OLEDropMode = UserControl.OLEDropMode
  821. End Property

  822. Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants)
  823.     Select Case Value
  824.     Case OLEDropModeNone, OLEDropModeManual
  825.         UserControl.OLEDropMode = Value
  826.     Case Else
  827.         ERR.Raise 380
  828.     End Select
  829.     UserControl.PropertyChanged "OLEDropMode"
  830. End Property

  831. Public Property Get MousePointer() As Integer
  832.     MousePointer = PropMousePointer
  833. End Property

  834. Public Property Let MousePointer(ByVal Value As Integer)
  835.     Select Case Value
  836.     Case 0 To 16, 99
  837.         PropMousePointer = Value
  838.     Case Else
  839.         ERR.Raise 380
  840.     End Select
  841.     UserControl.PropertyChanged "MousePointer"
  842. End Property

  843. Public Property Get MouseIcon() As IPictureDisp
  844.     Set MouseIcon = PropMouseIcon
  845. End Property

  846. Public Property Let MouseIcon(ByVal Value As IPictureDisp)
  847.     Set Me.MouseIcon = Value
  848. End Property

  849. Public Property Set MouseIcon(ByVal Value As IPictureDisp)
  850. If Value Is Nothing Then
  851.     Set PropMouseIcon = Nothing
  852. Else
  853.     If Value.Type = vbPicTypeIcon Or Value.Handle = 0 Then
  854.         Set PropMouseIcon = Value
  855.     Else
  856.         If ListBoxDesignMode = True Then
  857.             MsgBox "Invalid property value", vbCritical + vbOKOnly
  858.             Exit Property
  859.         Else
  860.             ERR.Raise 380
  861.         End If
  862.     End If
  863. End If
  864. UserControl.PropertyChanged "MouseIcon"
  865. End Property

  866. Public Property Get MouseTrack() As Boolean
  867.     MouseTrack = PropMouseTrack
  868. End Property

  869. Public Property Let MouseTrack(ByVal Value As Boolean)
  870.     PropMouseTrack = Value
  871.     UserControl.PropertyChanged "MouseTrack"
  872. End Property

  873. Public Property Get RightToLeft() As Boolean
  874.     RightToLeft = PropRightToLeft
  875. End Property

  876. Public Property Let RightToLeft(ByVal Value As Boolean)
  877.     PropRightToLeft = Value
  878.     UserControl.RightToLeft = PropRightToLeft
  879.     Call ComCtlsCheckRightToLeft(PropRightToLeft, UserControl.RightToLeft, PropRightToLeftMode)
  880.     Dim dwMask As Long
  881.     If PropRightToLeft = True Then dwMask = WS_EX_RTLREADING Or WS_EX_RIGHT Or WS_EX_LEFTSCROLLBAR
  882.     If ListBoxHandle <> 0 Then Call ComCtlsSetRightToLeft(ListBoxHandle, dwMask)
  883.     UserControl.PropertyChanged "RightToLeft"
  884. End Property

  885. Public Property Get RightToLeftMode() As CCRightToLeftModeConstants
  886.     RightToLeftMode = PropRightToLeftMode
  887. End Property

  888. Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants)
  889.     Select Case Value
  890.     Case CCRightToLeftModeNoControl, CCRightToLeftModeVBAME, CCRightToLeftModeSystemLocale, CCRightToLeftModeUserLocale, CCRightToLeftModeOSLanguage
  891.         PropRightToLeftMode = Value
  892.     Case Else
  893.         ERR.Raise 380
  894.     End Select
  895.     Me.RightToLeft = PropRightToLeft
  896.     UserControl.PropertyChanged "RightToLeftMode"
  897. End Property

  898. Public Property Get Redraw() As Boolean
  899.     Redraw = PropRedraw
  900. End Property

  901. Public Property Let Redraw(ByVal Value As Boolean)
  902.     PropRedraw = Value
  903.     If ListBoxHandle <> 0 And ListBoxDesignMode = False Then
  904.         SendMessage ListBoxHandle, WM_SETREDRAW, IIf(PropRedraw = True, 1, 0), ByVal 0&
  905.         If PropRedraw = True Then Me.Refresh
  906.     End If
  907.     UserControl.PropertyChanged "Redraw"
  908. End Property

  909. Public Property Get BorderStyle() As CCBorderStyleConstants
  910.     BorderStyle = PropBorderStyle
  911. End Property

  912. Public Property Let BorderStyle(ByVal Value As CCBorderStyleConstants)
  913.     Select Case Value
  914.     Case CCBorderStyleNone, CCBorderStyleSingle, CCBorderStyleThin, CCBorderStyleSunken, CCBorderStyleRaised
  915.         PropBorderStyle = Value
  916.     Case Else
  917.         ERR.Raise 380
  918.     End Select
  919.     If ListBoxHandle <> 0 Then
  920.         Call ComCtlsChangeBorderStyle(ListBoxHandle, PropBorderStyle)
  921.         Call UserControl_Resize
  922.     End If
  923.     UserControl.PropertyChanged "BorderStyle"
  924. End Property

  925. Public Property Get MultiColumn() As Boolean
  926.     MultiColumn = PropMultiColumn
  927. End Property

  928. Public Property Let MultiColumn(ByVal Value As Boolean)
  929.     If PropDrawMode = LstDrawModeOwnerDrawVariable And Value = True Then
  930.         If ListBoxDesignMode = True Then
  931.             MsgBox "MultiColumn must be False when DrawMode is 2 - OwnerDrawVariable", vbCritical + vbOKOnly
  932.             Exit Property
  933.         Else
  934.             ERR.Raise Number:=383, Description:="MultiColumn must be False when DrawMode is 2 - OwnerDrawVariable"
  935.         End If
  936.     End If
  937.     PropMultiColumn = Value
  938.     If ListBoxHandle <> 0 Then Call ReCreateListBox
  939.     UserControl.PropertyChanged "MultiColumn"
  940. End Property

  941. Public Property Get Sorted() As Boolean
  942.     Sorted = PropSorted
  943. End Property

  944. Public Property Let Sorted(ByVal Value As Boolean)
  945.     PropSorted = Value
  946.     If ListBoxHandle <> 0 Then Call ReCreateListBox
  947.     UserControl.PropertyChanged "Sorted"
  948. End Property

  949. Public Property Get IntegralHeight() As Boolean
  950.     IntegralHeight = PropIntegralHeight
  951. End Property

  952. Public Property Let IntegralHeight(ByVal Value As Boolean)
  953.     If ListBoxDesignMode = False Then
  954.         ERR.Raise Number:=382, Description:="IntegralHeight property is read-only at run time"
  955.     Else
  956.         PropIntegralHeight = Value
  957.         If ListBoxHandle <> 0 Then Call ReCreateListBox
  958.     End If
  959.     UserControl.PropertyChanged "IntegralHeight"
  960. End Property

  961. Public Property Get AllowSelection() As Boolean
  962.     AllowSelection = PropAllowSelection
  963. End Property

  964. Public Property Let AllowSelection(ByVal Value As Boolean)
  965.     PropAllowSelection = Value
  966.     If ListBoxHandle <> 0 Then Call ReCreateListBox
  967.     UserControl.PropertyChanged "AllowSelection"
  968. End Property

  969. Public Property Get MultiSelect() As VBRUN.MultiSelectConstants
  970.     MultiSelect = PropMultiSelect
  971. End Property

  972. Public Property Let MultiSelect(ByVal Value As VBRUN.MultiSelectConstants)
  973.     Select Case Value
  974.     Case vbMultiSelectNone, vbMultiSelectSimple, vbMultiSelectExtended
  975.         If PropStyle <> LstStyleStandard And Value <> vbMultiSelectNone Then
  976.             If ListBoxDesignMode = True Then
  977.                 MsgBox "MultiSelect must be 0 - None when Style is not 0 - Standard", vbCritical + vbOKOnly
  978.                 Exit Property
  979.             Else
  980.                 ERR.Raise Number:=383, Description:="MultiSelect must be 0 - None when Style is not 0 - Standard"
  981.             End If
  982.         End If
  983.         PropMultiSelect = Value
  984.     Case Else
  985.         ERR.Raise 380
  986.     End Select
  987.     If ListBoxHandle <> 0 Then Call ReCreateListBox
  988.     UserControl.PropertyChanged "MultiSelect"
  989. End Property

  990. Public Property Get HorizontalExtent() As Single
  991.     If ListBoxHandle <> 0 And PropMultiColumn = False Then
  992.         HorizontalExtent = UserControl.ScaleX(SendMessage(ListBoxHandle, LB_GETHORIZONTALEXTENT, 0, ByVal 0&), vbPixels, vbContainerSize)
  993.     Else
  994.         HorizontalExtent = UserControl.ScaleX(PropHorizontalExtent, vbPixels, vbContainerSize)
  995.     End If
  996. End Property

  997. Public Property Let HorizontalExtent(ByVal Value As Single)
  998.     If Value < 0 Then
  999.         If ListBoxDesignMode = True Then
  1000.             MsgBox "Invalid property value", vbCritical + vbOKOnly
  1001.             Exit Property
  1002.         Else
  1003.             ERR.Raise 380
  1004.         End If
  1005.     End If
  1006.     PropHorizontalExtent = CLng(UserControl.ScaleX(Value, vbContainerSize, vbPixels))
  1007.     If ListBoxHandle <> 0 And PropMultiColumn = False Then SendMessage ListBoxHandle, LB_SETHORIZONTALEXTENT, PropHorizontalExtent, ByVal 0&
  1008.     UserControl.PropertyChanged "HorizontalExtent"
  1009. End Property

  1010. Public Property Get UseTabStops() As Boolean
  1011.     UseTabStops = PropUseTabStops
  1012. End Property

  1013. Public Property Let UseTabStops(ByVal Value As Boolean)
  1014.     PropUseTabStops = Value
  1015.     If ListBoxHandle <> 0 Then Call ReCreateListBox
  1016.     UserControl.PropertyChanged "UseTabStops"
  1017. End Property

  1018. Public Property Get Style() As LstStyleConstants
  1019.     Style = PropStyle
  1020. End Property

  1021. Public Property Let Style(ByVal Value As LstStyleConstants)
  1022.     If ListBoxDesignMode = False Then
  1023.         ERR.Raise Number:=382, Description:="Style property is read-only at run time"
  1024.     Else
  1025.         Select Case Value
  1026.         Case LstStyleStandard, LstStyleCheckbox, LstStyleOption
  1027.             If PropDrawMode <> LstDrawModeNormal And Value <> LstStyleStandard Then
  1028.                 MsgBox "Style must be 0 - Standard when DrawMode is not 0 - Normal", vbCritical + vbOKOnly
  1029.                 Exit Property
  1030.             End If
  1031.             PropStyle = Value
  1032.             If PropStyle <> LstStyleStandard Then PropMultiSelect = vbMultiSelectNone
  1033.         Case Else
  1034.             ERR.Raise 380
  1035.         End Select
  1036.         If ListBoxHandle <> 0 Then Call ReCreateListBox
  1037.     End If
  1038.     UserControl.PropertyChanged "Style"
  1039. End Property

  1040. Public Property Get DisableNoScroll() As Boolean
  1041.     DisableNoScroll = PropDisableNoScroll
  1042. End Property

  1043. Public Property Let DisableNoScroll(ByVal Value As Boolean)
  1044.     PropDisableNoScroll = Value
  1045.     If ListBoxHandle <> 0 Then Call ReCreateListBox
  1046.     UserControl.PropertyChanged "DisableNoScroll"
  1047. End Property

  1048. Public Property Get DrawMode() As LstDrawModeConstants
  1049.     DrawMode = PropDrawMode
  1050. End Property

  1051. Public Property Let DrawMode(ByVal Value As LstDrawModeConstants)
  1052.     Select Case Value
  1053.     Case LstDrawModeNormal, LstDrawModeOwnerDrawFixed, LstDrawModeOwnerDrawVariable
  1054.         If ListBoxDesignMode = False Then
  1055.             ERR.Raise Number:=382, Description:="DrawMode property is read-only at run time"
  1056.         Else
  1057.             PropDrawMode = Value
  1058.         End If
  1059.     Case Else
  1060.         ERR.Raise 380
  1061.     End Select
  1062.     If ListBoxHandle <> 0 Then Call ReCreateListBox
  1063.     UserControl.PropertyChanged "DrawMode"
  1064. End Property

  1065. Public Property Get InsertMarkColor() As OLE_COLOR
  1066.     InsertMarkColor = PropInsertMarkColor
  1067. End Property

  1068. Public Property Let InsertMarkColor(ByVal Value As OLE_COLOR)
  1069.     PropInsertMarkColor = Value
  1070.     If ListBoxInsertMark > -1 Then Call InvalidateInsertMark
  1071.     UserControl.PropertyChanged "InsertMarkColor"
  1072. End Property

  1073. Public Property Get ScrollTrack() As Boolean
  1074.     ScrollTrack = PropScrollTrack
  1075. End Property

  1076. Public Property Let ScrollTrack(ByVal Value As Boolean)
  1077.     PropScrollTrack = Value
  1078.     UserControl.PropertyChanged "ScrollTrack"
  1079. End Property

  1080. Public Sub AddItem(ByVal Item As String, Optional ByVal Index As Variant)
  1081.     If ListBoxHandle <> 0 Then
  1082.         Dim RetVal As Long
  1083.         If IsMissing(Index) = True Then
  1084.             RetVal = SendMessage(ListBoxHandle, LB_ADDSTRING, 0, ByVal StrPtr(Item))
  1085.         Else
  1086.             Dim IndexLong As Long
  1087.             Select Case VarType(Index)
  1088.             Case vbLong, vbInteger, vbByte
  1089.                 If Index >= 0 Then
  1090.                     IndexLong = Index
  1091.                 Else
  1092.                     ERR.Raise 5
  1093.                 End If
  1094.             Case vbDouble, vbSingle
  1095.                 If CLng(Index) >= 0 Then
  1096.                     IndexLong = CLng(Index)
  1097.                 Else
  1098.                     ERR.Raise 5
  1099.                 End If
  1100.             Case vbString
  1101.                 IndexLong = CLng(Index)
  1102.                 If IndexLong < 0 Then ERR.Raise 5
  1103.             Case Else
  1104.                 ERR.Raise 13
  1105.             End Select
  1106.             RetVal = SendMessage(ListBoxHandle, LB_INSERTSTRING, IndexLong, ByVal StrPtr(Item))
  1107.         End If
  1108.         If Not RetVal = LB_ERR Then
  1109.             ListBoxNewIndex = RetVal
  1110.             If PropStyle <> LstStyleStandard Then
  1111.                 ListBoxItemCheckedCount = ListBoxItemCheckedCount + 1
  1112.                 If PropStyle = LstStyleCheckbox Then
  1113.                     ReDim Preserve ListBoxItemChecked(0 To ListBoxItemCheckedCount) As Byte
  1114.                     If ListBoxNewIndex < (ListBoxItemCheckedCount - 1) Then CopyMemory ByVal VarPtr(ListBoxItemChecked(ListBoxNewIndex + 2)), ByVal VarPtr(ListBoxItemChecked(ListBoxNewIndex + 1)), (ListBoxItemCheckedCount - ListBoxNewIndex - 1)
  1115.                     ListBoxItemChecked(ListBoxNewIndex + 1) = vbUnchecked
  1116.                 ElseIf PropStyle = LstStyleOption Then
  1117.                     If ListBoxNewIndex <= ListBoxOptionIndex Then ListBoxOptionIndex = ListBoxOptionIndex + 1
  1118.                 End If
  1119.             End If
  1120.         Else
  1121.             ERR.Raise 5
  1122.         End If
  1123.     End If
  1124. End Sub

  1125. Public Sub RemoveItem(ByVal Index As Long)
  1126.     If ListBoxHandle <> 0 Then
  1127.         If Index >= 0 Then
  1128.             If Not SendMessage(ListBoxHandle, LB_DELETESTRING, Index, ByVal 0&) = LB_ERR Then
  1129.                 ListBoxNewIndex = -1
  1130.                 If ListBoxInsertMark > -1 Then
  1131.                     If ListBoxInsertMark > (SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&) - 1) Then
  1132.                         ListBoxInsertMark = -1
  1133.                         ListBoxInsertMarkAfter = False
  1134.                     End If
  1135.                 End If
  1136.                 If PropStyle <> LstStyleStandard Then
  1137.                     ListBoxItemCheckedCount = ListBoxItemCheckedCount - 1
  1138.                     If PropStyle = LstStyleCheckbox Then
  1139.                         If ListBoxItemCheckedCount > 0 Then
  1140.                             If Index < ListBoxItemCheckedCount Then CopyMemory ByVal VarPtr(ListBoxItemChecked(Index + 1)), ByVal VarPtr(ListBoxItemChecked(Index + 2)), (ListBoxItemCheckedCount - Index)
  1141.                             ReDim Preserve ListBoxItemChecked(0 To ListBoxItemCheckedCount) As Byte
  1142.                         Else
  1143.                             ReDim ListBoxItemChecked(0) As Byte
  1144.                         End If
  1145.                     ElseIf PropStyle = LstStyleOption Then
  1146.                         If ListBoxOptionIndex > -1 Then
  1147.                             If ListBoxItemCheckedCount > 0 Then
  1148.                                 If ListBoxOptionIndex > (SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&) - 1) Then
  1149.                                     ListBoxOptionIndex = -1
  1150.                                 ElseIf Index = ListBoxOptionIndex Then
  1151.                                     ListBoxOptionIndex = -1
  1152.                                 ElseIf Index < ListBoxOptionIndex Then
  1153.                                     ListBoxOptionIndex = ListBoxOptionIndex - 1
  1154.                                 End If
  1155.                             Else
  1156.                                 ListBoxOptionIndex = -1
  1157.                             End If
  1158.                         End If
  1159.                     End If
  1160.                 End If
  1161.             Else
  1162.                 ERR.Raise 5
  1163.             End If
  1164.         Else
  1165.             ERR.Raise 5
  1166.         End If
  1167.     End If
  1168. End Sub

  1169. Public Sub Clear()
  1170.     If ListBoxHandle <> 0 Then
  1171.         SendMessage ListBoxHandle, LB_RESETCONTENT, 0, ByVal 0&
  1172.         ListBoxNewIndex = -1
  1173.         If PropStyle <> LstStyleStandard Then
  1174.             ListBoxItemCheckedCount = 0
  1175.             ReDim ListBoxItemChecked(0) As Byte
  1176.             ListBoxOptionIndex = -1
  1177.         End If
  1178.     End If
  1179. End Sub

  1180. Public Property Get ListCount() As Long
  1181. If ListBoxHandle <> 0 Then ListCount = SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&)
  1182. End Property

  1183. Public Property Get List(ByVal Index As Long) As String
  1184.     If ListBoxHandle <> 0 Then
  1185.         Dim Length As Long
  1186.         Length = SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&)
  1187.         If Not Length = LB_ERR Then
  1188.             List = String(Length, vbNullChar)
  1189.             SendMessage ListBoxHandle, LB_GETTEXT, Index, ByVal StrPtr(List)
  1190.         Else
  1191.             ERR.Raise 5
  1192.         End If
  1193.     End If
  1194. End Property

  1195. Public Property Let List(ByVal Index As Long, ByVal Value As String)
  1196.     If ListBoxHandle <> 0 Then
  1197.         If Index > -1 Then
  1198.             Dim ListIndex As Long, SelVal As Long, ItemData As Long
  1199.             ListIndex = Me.ListIndex
  1200.             If PropMultiSelect <> vbMultiSelectNone Then SelVal = SendMessage(ListBoxHandle, LB_GETSEL, Index, ByVal 0&)
  1201.             ItemData = SendMessage(ListBoxHandle, LB_GETITEMDATA, Index, ByVal 0&)
  1202.             If Not SendMessage(ListBoxHandle, LB_DELETESTRING, Index, ByVal 0&) = LB_ERR Then
  1203.                 SendMessage ListBoxHandle, LB_INSERTSTRING, Index, ByVal StrPtr(Value)
  1204.                 Me.ListIndex = ListIndex
  1205.                 If PropMultiSelect <> vbMultiSelectNone And Not SelVal = LB_ERR Then SendMessage ListBoxHandle, LB_SETSEL, SelVal, ByVal Index
  1206.                 SendMessage ListBoxHandle, LB_SETITEMDATA, Index, ByVal ItemData
  1207.             Else
  1208.                 ERR.Raise 5
  1209.             End If
  1210.         Else
  1211.             ERR.Raise 5
  1212.         End If
  1213.     End If
  1214. End Property

  1215. Public Property Get ListIndex() As Long
  1216.     If ListBoxHandle <> 0 Then
  1217.         If PropMultiSelect = vbMultiSelectNone Then
  1218.             ListIndex = SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&)
  1219.         Else
  1220.             ListIndex = SendMessage(ListBoxHandle, LB_GETCARETINDEX, 0, ByVal 0&)
  1221.         End If
  1222.     End If
  1223. End Property

  1224. Public Property Let ListIndex(ByVal Value As Long)
  1225.     If ListBoxHandle <> 0 Then
  1226.         Dim Changed As Boolean
  1227.         If PropMultiSelect = vbMultiSelectNone Then
  1228.             Changed = CBool(SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&) <> Value)
  1229.             If Not Value = -1 Then
  1230.                 If SendMessage(ListBoxHandle, LB_SETCURSEL, Value, ByVal 0&) = LB_ERR Then ERR.Raise 380
  1231.             Else
  1232.                 SendMessage ListBoxHandle, LB_SETCURSEL, -1, ByVal 0&
  1233.             End If
  1234.         Else
  1235.             Changed = CBool(SendMessage(ListBoxHandle, LB_GETCARETINDEX, 0, ByVal 0&) <> Value)
  1236.             If SendMessage(ListBoxHandle, LB_SETCARETINDEX, Value, ByVal 0&) = LB_ERR Then ERR.Raise 380
  1237.         End If
  1238.         If Changed = True Then RaiseEvent Click
  1239.     End If
  1240. End Property

  1241. Public Property Get ItemData(ByVal Index As Long) As Long
  1242.     If ListBoxHandle <> 0 Then
  1243.         If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&) = LB_ERR Then
  1244.             ItemData = SendMessage(ListBoxHandle, LB_GETITEMDATA, Index, ByVal 0&)
  1245.         Else
  1246.             ERR.Raise 381
  1247.         End If
  1248.     End If
  1249. End Property

  1250. Public Property Let ItemData(ByVal Index As Long, ByVal Value As Long)
  1251.     If ListBoxHandle <> 0 Then If SendMessage(ListBoxHandle, LB_SETITEMDATA, Index, ByVal Value) = LB_ERR Then ERR.Raise 381
  1252. End Property

  1253. Public Property Get ItemChecked(ByVal Index As Long) As Boolean
  1254.     If ListBoxHandle <> 0 Then
  1255.         If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&) = LB_ERR Then
  1256.             If Index <= (ListBoxItemCheckedCount - 1) Then
  1257.                 If PropStyle = LstStyleCheckbox Then
  1258.                     ItemChecked = CBool(ListBoxItemChecked(Index + 1) = vbChecked)
  1259.                 ElseIf PropStyle = LstStyleOption Then
  1260.                     ItemChecked = CBool(ListBoxOptionIndex = Index)
  1261.                 End If
  1262.             End If
  1263.         Else
  1264.             ERR.Raise 381
  1265.         End If
  1266.     End If
  1267. End Property

  1268. Public Property Let ItemChecked(ByVal Index As Long, ByVal Value As Boolean)
  1269.     If ListBoxHandle <> 0 Then
  1270.         If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&) = LB_ERR Then
  1271.             If Index <= (ListBoxItemCheckedCount - 1) Then
  1272.                 Dim Changed As Boolean
  1273.                 If PropStyle = LstStyleCheckbox Then
  1274.                     Changed = CBool(ListBoxItemChecked(Index + 1) <> IIf(Value = True, vbChecked, vbUnchecked))
  1275.                 ElseIf PropStyle = LstStyleOption Then
  1276.                     If ListBoxOptionIndex <> Index Then
  1277.                         Changed = Value
  1278.                     ElseIf Value = False Then
  1279.                         Changed = True
  1280.                     End If
  1281.                 End If
  1282.                 If Changed = True Then
  1283.                     Dim Cancel As Boolean
  1284.                     RaiseEvent ItemBeforeCheck(Index, Cancel)
  1285.                     If Cancel = False Then
  1286.                         Dim RC As RECT
  1287.                         If PropStyle = LstStyleCheckbox Then
  1288.                             ListBoxItemChecked(Index + 1) = IIf(Value = True, vbChecked, vbUnchecked)
  1289.                         ElseIf PropStyle = LstStyleOption Then
  1290.                             If ListBoxOptionIndex > -1 Then
  1291.                                 SendMessage ListBoxHandle, LB_GETITEMRECT, ListBoxOptionIndex, ByVal VarPtr(RC)
  1292.                                 InvalidateRect ListBoxHandle, RC, 0
  1293.                             End If
  1294.                             If ListBoxOptionIndex <> Index Then
  1295.                                 ListBoxOptionIndex = Index
  1296.                             ElseIf Value = False Then
  1297.                                 ListBoxOptionIndex = -1
  1298.                             End If
  1299.                         End If
  1300.                         SendMessage ListBoxHandle, LB_GETITEMRECT, Index, ByVal VarPtr(RC)
  1301.                         InvalidateRect ListBoxHandle, RC, 0
  1302.                         RaiseEvent ItemCheck(Index)
  1303.                     End If
  1304.                 End If
  1305.             End If
  1306.         Else
  1307.             ERR.Raise 381
  1308.         End If
  1309.     End If
  1310. End Property

  1311. Private Sub CreateListBox()
  1312.     If ListBoxHandle <> 0 Then Exit Sub
  1313.     Dim dwStyle As Long, dwExStyle As Long
  1314.     dwStyle = WS_CHILD Or WS_VISIBLE Or LBS_NOTIFY Or WS_HSCROLL
  1315.     If PropRedraw = False Then dwStyle = dwStyle Or LBS_NOREDRAW
  1316.     Call ComCtlsInitBorderStyle(dwStyle, dwExStyle, PropBorderStyle)
  1317.     If PropDrawMode = LstDrawModeOwnerDrawVariable Then
  1318.         ' The LBS_MULTICOLUMN and LBS_OWNERDRAWVARIABLE styles cannot be combined.
  1319.         PropMultiColumn = False
  1320.         ' In an variable owner-drawn list box it makes no sense to have an integral height.
  1321.         ' Otherwise it would come to unpredictable adjustments.
  1322.         PropIntegralHeight = False
  1323.     End If
  1324.     If PropMultiColumn = False Then
  1325.         dwStyle = dwStyle Or WS_VSCROLL
  1326.         If PropRightToLeft = True Then dwExStyle = dwExStyle Or WS_EX_RTLREADING Or WS_EX_RIGHT Or WS_EX_LEFTSCROLLBAR
  1327.     Else
  1328.         dwStyle = dwStyle Or LBS_MULTICOLUMN
  1329.     End If
  1330.     If PropSorted = True Then dwStyle = dwStyle Or LBS_SORT
  1331.     If PropIntegralHeight = False Then dwStyle = dwStyle Or LBS_NOINTEGRALHEIGHT
  1332.     If PropAllowSelection = False Then dwStyle = dwStyle Or LBS_NOSEL
  1333.     Select Case PropMultiSelect
  1334.     Case vbMultiSelectSimple
  1335.         dwStyle = dwStyle Or LBS_MULTIPLESEL
  1336.     Case vbMultiSelectExtended
  1337.         dwStyle = dwStyle Or LBS_EXTENDEDSEL
  1338.     End Select
  1339.     If PropUseTabStops = True Then dwStyle = dwStyle Or LBS_USETABSTOPS
  1340.     If PropDrawMode <> LstDrawModeNormal Then PropStyle = vbListBoxStandard
  1341.     If PropStyle <> LstStyleStandard Then dwStyle = dwStyle Or LBS_OWNERDRAWFIXED Or LBS_HASSTRINGS
  1342.     If PropDisableNoScroll = True Then dwStyle = dwStyle Or LBS_DISABLENOSCROLL
  1343.     Select Case PropDrawMode
  1344.     Case LstDrawModeOwnerDrawFixed
  1345.         dwStyle = dwStyle Or LBS_OWNERDRAWFIXED Or LBS_HASSTRINGS
  1346.     Case LstDrawModeOwnerDrawVariable
  1347.         dwStyle = dwStyle Or LBS_OWNERDRAWVARIABLE Or LBS_HASSTRINGS
  1348.     End Select
  1349.     ListBoxHandle = CreateWindowEx(dwExStyle, StrPtr("ListBox"), 0, dwStyle, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight, UserControl.hwnd, 0, App.hInstance, ByVal 0&)
  1350.     If ListBoxHandle <> 0 Then
  1351.         Call ComCtlsShowAllUIStates(ListBoxHandle)
  1352.         If PropMultiColumn = True And PropRightToLeft = True Then
  1353.             ' In a multi-column list box it is necessary to set the right-to-left alignment afterwards.
  1354.             ' Else the top index gets negative and everything will be unpredictable and unstable. (Bug?)
  1355.             Call ComCtlsSetRightToLeft(ListBoxHandle, WS_EX_RTLREADING Or WS_EX_RIGHT Or WS_EX_LEFTSCROLLBAR)
  1356.         End If
  1357.         If PropMultiColumn = False And PropHorizontalExtent > 0 Then SendMessage ListBoxHandle, LB_SETHORIZONTALEXTENT, PropHorizontalExtent, ByVal 0&
  1358.         ListBoxNewIndex = -1
  1359.         ListBoxTopIndex = 0
  1360.         ListBoxInsertMark = -1
  1361.         ListBoxInsertMarkAfter = False
  1362.         ListBoxOptionIndex = -1
  1363.     End If
  1364.     Set Me.Font = PropFont
  1365.     Me.VisualStyles = PropVisualStyles
  1366.     Me.Enabled = UserControl.Enabled
  1367.     If ListBoxDesignMode = False Then
  1368.         If ListBoxHandle <> 0 Then Call ComCtlsSetSubclass(ListBoxHandle, Me, 1)
  1369.         Call ComCtlsSetSubclass(UserControl.hwnd, Me, 2)
  1370.     Else
  1371.         If ListBoxHandle <> 0 Then
  1372.             Dim Buffer As String
  1373.             Buffer = Ambient.DisplayName
  1374.             SendMessage ListBoxHandle, LB_ADDSTRING, 0, ByVal StrPtr(Buffer)
  1375.             SendMessage ListBoxHandle, LB_SETCURSEL, -1, ByVal 0&
  1376.         End If
  1377.         If PropStyle <> LstStyleStandard Then
  1378.             Call ComCtlsSetSubclass(UserControl.hwnd, Me, 3)
  1379.             Me.Refresh
  1380.         End If
  1381.     End If
  1382. End Sub

  1383. Private Sub ReCreateListBox()
  1384.     If ListBoxDesignMode = False Then
  1385.         Dim Locked As Boolean
  1386.         With Me
  1387.             Locked = CBool(LockWindowUpdate(UserControl.hwnd) <> 0)
  1388.             Dim ListArr() As String, ItemDataArr() As Long, ItemSelArr() As Long
  1389.             Dim ItemHeight As Long, ListIndex As Long, TopIndex As Long, NewIndex As Long, InsertMark As Long, InsertMarkAfter As Boolean
  1390.             Dim Count As Long, i As Long
  1391.             If ListBoxHandle <> 0 Then
  1392.                 ItemHeight = SendMessage(ListBoxHandle, LB_GETITEMHEIGHT, 0, ByVal 0&)
  1393.                 Count = SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&)
  1394.                 If Count > 0 Then
  1395.                     ReDim ListArr(0 To (Count - 1)) As String
  1396.                     ReDim ItemDataArr(0 To (Count - 1)) As Long
  1397.                     ReDim ItemSelArr(0 To (Count - 1)) As Long
  1398.                     For i = 0 To (Count - 1)
  1399.                         ListArr(i) = .List(i)
  1400.                         ItemDataArr(i) = SendMessage(ListBoxHandle, LB_GETITEMDATA, i, ByVal 0&)
  1401.                         If PropMultiSelect <> vbMultiSelectNone Then ItemSelArr(i) = SendMessage(ListBoxHandle, LB_GETSEL, i, ByVal 0&)
  1402.                     Next i
  1403.                 End If
  1404.                 ListIndex = .ListIndex
  1405.                 TopIndex = .TopIndex
  1406.             End If
  1407.             NewIndex = ListBoxNewIndex
  1408.             InsertMark = ListBoxInsertMark
  1409.             InsertMarkAfter = ListBoxInsertMarkAfter
  1410.             Call DestroyListBox
  1411.             Call CreateListBox
  1412.             Call UserControl_Resize
  1413.             If ListBoxHandle <> 0 Then
  1414.                 SendMessage ListBoxHandle, LB_SETITEMHEIGHT, 0, ByVal ItemHeight
  1415.                 If Count > 0 Then
  1416.                     SendMessage ListBoxHandle, WM_SETREDRAW, 0, ByVal 0&
  1417.                     For i = 0 To (Count - 1)
  1418.                         SendMessage ListBoxHandle, LB_INSERTSTRING, i, ByVal StrPtr(ListArr(i))
  1419.                         SendMessage ListBoxHandle, LB_SETITEMDATA, i, ByVal ItemDataArr(i)
  1420.                         If PropMultiSelect <> vbMultiSelectNone Then SendMessage ListBoxHandle, LB_SETSEL, ItemSelArr(i), ByVal i
  1421.                     Next i
  1422.                     SendMessage ListBoxHandle, WM_SETREDRAW, 1, ByVal 0&
  1423.                 End If
  1424.                 .ListIndex = ListIndex
  1425.                 .TopIndex = TopIndex
  1426.             End If
  1427.             ListBoxNewIndex = NewIndex
  1428.             ListBoxInsertMark = InsertMark
  1429.             ListBoxInsertMarkAfter = InsertMarkAfter
  1430.             If Locked = True Then LockWindowUpdate 0
  1431.             .Refresh
  1432.             If PropRedraw = False Then .Redraw = PropRedraw
  1433.         End With
  1434.         
  1435.     Else
  1436.         Call DestroyListBox
  1437.         Call ComCtlsRemoveSubclass(UserControl.hwnd)
  1438.         Call CreateListBox
  1439.         Call UserControl_Resize
  1440.     End If
  1441. End Sub

  1442. Private Sub DestroyListBox()
  1443.     If ListBoxHandle = 0 Then Exit Sub
  1444.     Call ComCtlsRemoveSubclass(ListBoxHandle)
  1445.     Call ComCtlsRemoveSubclass(UserControl.hwnd)
  1446.     ShowWindow ListBoxHandle, SW_HIDE
  1447.     SetParent ListBoxHandle, 0
  1448.     DestroyWindow ListBoxHandle
  1449.     ListBoxHandle = 0
  1450.     If ListBoxFontHandle <> 0 Then
  1451.         DeleteObject ListBoxFontHandle
  1452.         ListBoxFontHandle = 0
  1453.     End If
  1454. End Sub

  1455. Public Sub Refresh()
  1456.     UserControl.Refresh
  1457.     If PropRedraw = True Or ListBoxDesignMode = True Then RedrawWindow UserControl.hwnd, 0, 0, RDW_UPDATENOW Or RDW_INVALIDATE Or RDW_ERASE Or RDW_ALLCHILDREN
  1458. End Sub

  1459. Public Property Get Text() As String
  1460.     If ListBoxHandle <> 0 Then
  1461.         Dim Index As Long
  1462.         Index = Me.ListIndex
  1463.         If Index > -1 Then Text = Me.List(Index)
  1464.     End If
  1465. End Property

  1466. Public Property Let Text(ByVal Value As String)
  1467.     If ListBoxHandle <> 0 Then Me.ListIndex = SendMessage(ListBoxHandle, LB_FINDSTRINGEXACT, -1, ByVal StrPtr(Value))
  1468. End Property

  1469. Public Property Get SelCount() As Long
  1470. If ListBoxHandle <> 0 Then
  1471.     Dim RetVal As Long
  1472.     RetVal = SendMessage(ListBoxHandle, LB_GETSELCOUNT, 0, ByVal 0&)
  1473.     If Not RetVal = LB_ERR Then
  1474.         SelCount = RetVal
  1475.     Else
  1476.         RetVal = SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&)
  1477.         If Not RetVal = LB_ERR Then
  1478.             RetVal = SendMessage(ListBoxHandle, LB_GETSEL, RetVal, ByVal 0&)
  1479.             If RetVal > 0 Then SelCount = 1
  1480.         End If
  1481.     End If
  1482. End If
  1483. End Property

  1484. Public Property Get Selected(ByVal Index As Long) As Boolean
  1485.     If ListBoxHandle <> 0 Then
  1486.         If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&) = LB_ERR Then
  1487.             Selected = CBool(SendMessage(ListBoxHandle, LB_GETSEL, Index, ByVal 0&) > 0)
  1488.         Else
  1489.             ERR.Raise 381
  1490.         End If
  1491.     End If
  1492. End Property

  1493. Public Property Let Selected(ByVal Index As Long, ByVal Value As Boolean)
  1494.     If ListBoxHandle <> 0 Then
  1495.         If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&) = LB_ERR Then
  1496.             Dim Changed As Boolean, RetVal As Long
  1497.             If PropMultiSelect <> vbMultiSelectNone Then
  1498.                 RetVal = IIf(SendMessage(ListBoxHandle, LB_GETSEL, Index, ByVal 0&) > 0, 1, 0)
  1499.                 SendMessage ListBoxHandle, LB_SETSEL, IIf(Value = True, 1, 0), ByVal Index
  1500.                 Changed = CBool(IIf(SendMessage(ListBoxHandle, LB_GETSEL, Index, ByVal 0&) > 0, 1, 0) <> RetVal)
  1501.             Else
  1502.                 RetVal = SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&)
  1503.                 If Value = False Then
  1504.                     If SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&) = Index Then
  1505.                         If SendMessage(ListBoxHandle, LB_GETSEL, Index, ByVal 0&) > 0 Then SendMessage ListBoxHandle, LB_SETCURSEL, -1, ByVal 0&
  1506.                     End If
  1507.                 Else
  1508.                     SendMessage ListBoxHandle, LB_SETCURSEL, Index, ByVal 0&
  1509.                 End If
  1510.                 Changed = CBool(SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&) <> RetVal)
  1511.             End If
  1512.             If Changed = True Then RaiseEvent Click
  1513.         Else
  1514.             ERR.Raise 381
  1515.         End If
  1516.     End If
  1517. End Property

  1518. Public Sub SetSelRange(ByVal StartIndex As Long, ByVal EndIndex As Long)
  1519.     If ListBoxHandle <> 0 Then
  1520.         If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, StartIndex, ByVal 0&) = LB_ERR And Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, EndIndex, ByVal 0&) = LB_ERR Then
  1521.             Dim RetVal As Long
  1522.             RetVal = SendMessage(ListBoxHandle, LB_GETSELCOUNT, 0, ByVal 0&)
  1523.             If Not RetVal = LB_ERR Then
  1524.                 Dim Changed As Boolean
  1525.                 SendMessage ListBoxHandle, LB_SELITEMRANGEEX, StartIndex, ByVal EndIndex
  1526.                 Changed = CBool(SendMessage(ListBoxHandle, LB_GETSELCOUNT, 0, ByVal 0&) <> RetVal)
  1527.                 If Changed = True Then RaiseEvent Click
  1528.             Else
  1529.                 Me.ListIndex = StartIndex
  1530.             End If
  1531.         Else
  1532.             ERR.Raise 381
  1533.         End If
  1534.     End If
  1535. End Sub

  1536. Public Property Get ItemHeight(Optional ByVal Index As Long) As Single
  1537.     If ListBoxHandle <> 0 Then
  1538.         Dim RetVal As Long
  1539.         If PropDrawMode <> LstDrawModeOwnerDrawVariable Then
  1540.             If Index = 0 Then
  1541.                 RetVal = SendMessage(ListBoxHandle, LB_GETITEMHEIGHT, 0, ByVal 0&)
  1542.             Else
  1543.                 RetVal = LB_ERR
  1544.             End If
  1545.         Else
  1546.             RetVal = SendMessage(ListBoxHandle, LB_GETITEMHEIGHT, Index, ByVal 0&)
  1547.         End If
  1548.         If Not RetVal = LB_ERR Then
  1549.             ItemHeight = UserControl.ScaleY(RetVal, vbPixels, vbContainerSize)
  1550.         Else
  1551.             ERR.Raise 5
  1552.         End If
  1553.     End If
  1554. End Property

  1555. Public Property Let ItemHeight(Optional ByVal Index As Long, ByVal Value As Single)
  1556.     If Value < 0 Then ERR.Raise 380
  1557.     If ListBoxHandle <> 0 Then
  1558.         Dim RetVal As Long
  1559.         If PropDrawMode <> LstDrawModeOwnerDrawVariable Then
  1560.             If Index = 0 Then
  1561.                 RetVal = SendMessage(ListBoxHandle, LB_SETITEMHEIGHT, 0, ByVal CLng(UserControl.ScaleY(Value, vbContainerSize, vbPixels)))
  1562.             Else
  1563.                 RetVal = LB_ERR
  1564.             End If
  1565.         Else
  1566.             RetVal = SendMessage(ListBoxHandle, LB_SETITEMHEIGHT, Index, ByVal CLng(UserControl.ScaleY(Value, vbContainerSize, vbPixels)))
  1567.         End If
  1568.         If Not RetVal = LB_ERR Then
  1569.             If PropIntegralHeight = True Then
  1570.                 With UserControl
  1571.                     MoveWindow ListBoxHandle, 0, 0, .ScaleWidth, .ScaleHeight + 10, 0
  1572.                     MoveWindow ListBoxHandle, 0, 0, .ScaleWidth, .ScaleHeight, 0
  1573.                 End With
  1574.                 Call UserControl_Resize
  1575.             End If
  1576.             Me.Refresh
  1577.         Else
  1578.             ERR.Raise 5
  1579.         End If
  1580.     End If
  1581. End Property

  1582. Public Property Get NewIndex() As Long
  1583. NewIndex = ListBoxNewIndex
  1584. End Property

  1585. Public Property Get TopIndex() As Long
  1586.     If ListBoxHandle <> 0 Then TopIndex = SendMessage(ListBoxHandle, LB_GETTOPINDEX, 0, ByVal 0&)
  1587. End Property

  1588. Public Property Let TopIndex(ByVal Value As Long)
  1589.     If ListBoxHandle <> 0 Then
  1590.         If Value >= 0 Then
  1591.             If SendMessage(ListBoxHandle, LB_SETTOPINDEX, Value, ByVal 0&) = LB_ERR Then ERR.Raise 380
  1592.         Else
  1593.             ERR.Raise 380
  1594.         End If
  1595.     End If
  1596. End Property

  1597. Public Property Get AnchorIndex() As Long
  1598.     If ListBoxHandle <> 0 Then AnchorIndex = SendMessage(ListBoxHandle, LB_GETANCHORINDEX, 0, ByVal 0&)
  1599. End Property

  1600. Public Property Let AnchorIndex(ByVal Value As Long)
  1601.     If ListBoxHandle <> 0 Then
  1602.         If Value < -1 Then
  1603.             ERR.Raise 380
  1604.         Else
  1605.             If SendMessage(ListBoxHandle, LB_SETANCHORINDEX, Value, ByVal 0&) = LB_ERR Then ERR.Raise 380
  1606.         End If
  1607.     End If
  1608. End Property

  1609. Public Sub SetColumnWidth(ByVal Value As Single)
  1610.     If Value < 0 Then ERR.Raise 380
  1611.     If ListBoxHandle <> 0 Then
  1612.         Dim LngValue As Long
  1613.         LngValue = CLng(UserControl.ScaleX(Value, vbContainerSize, vbPixels))
  1614.         If LngValue > 0 Then
  1615.             SendMessage ListBoxHandle, LB_SETCOLUMNWIDTH, LngValue, ByVal 0&
  1616.         Else
  1617.             ERR.Raise 380
  1618.         End If
  1619.     End If
  1620. End Sub

  1621. Public Function ItemsPerColumn() As Long
  1622.     If ListBoxHandle <> 0 Then ItemsPerColumn = SendMessage(ListBoxHandle, LB_GETLISTBOXINFO, 0, ByVal 0&)
  1623. End Function

  1624. Public Function SelectedIndices() As Collection
  1625.     If ListBoxHandle <> 0 Then
  1626.         Set SelectedIndices = New Collection
  1627.         Dim Count As Long
  1628.         Count = SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&)
  1629.         If Count > 0 Then
  1630.             Dim LngArr() As Long, RetVal As Long
  1631.             ReDim LngArr(1 To Count) As Long
  1632.             RetVal = SendMessage(ListBoxHandle, LB_GETSELITEMS, Count, ByVal VarPtr(LngArr(1)))
  1633.             If Not RetVal = LB_ERR Then
  1634.                 Dim i As Long
  1635.                 For i = 1 To RetVal
  1636.                     SelectedIndices.Add LngArr(i)
  1637.                 Next i
  1638.             Else
  1639.                 RetVal = SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&)
  1640.                 If Not RetVal = LB_ERR Then
  1641.                     If SendMessage(ListBoxHandle, LB_GETSEL, RetVal, ByVal 0&) > 0 Then
  1642.                         SelectedIndices.Add RetVal
  1643.                     End If
  1644.                 End If
  1645.             End If
  1646.         End If
  1647.     End If
  1648. End Function

  1649. Public Function CheckedIndices() As Collection
  1650.     If ListBoxHandle <> 0 Then
  1651.         Set CheckedIndices = New Collection
  1652.         Dim Count As Long
  1653.         Count = SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&)
  1654.         If Count > 0 Then
  1655.             If PropStyle = LstStyleCheckbox Then
  1656.                 Dim i As Long
  1657.                 For i = 1 To UBound(ListBoxItemChecked())
  1658.                     If ListBoxItemChecked(i) = vbChecked Then CheckedIndices.Add (i - 1)
  1659.                 Next i
  1660.             ElseIf PropStyle = LstStyleOption Then
  1661.                 If ListBoxOptionIndex > -1 Then CheckedIndices.Add ListBoxOptionIndex
  1662.             End If
  1663.         End If
  1664.     End If
  1665. End Function

  1666. Public Function HitTest(ByVal X As Single, ByVal Y As Single) As Long
  1667.     If ListBoxHandle <> 0 Then
  1668.         Dim p As POINTAPI
  1669.         p.X = UserControl.ScaleX(X, vbContainerPosition, vbPixels)
  1670.         p.Y = UserControl.ScaleY(Y, vbContainerPosition, vbPixels)
  1671.         ClientToScreen ListBoxHandle, p
  1672.         HitTest = LBItemFromPt(ListBoxHandle, p.X, p.Y, 0)
  1673.     End If
  1674. End Function

  1675. Public Function HitTestInsertMark(ByVal X As Single, ByVal Y As Single, Optional ByRef After As Boolean) As Long
  1676.     If ListBoxHandle <> 0 Then
  1677.         Dim p As POINTAPI, Index As Long
  1678.         p.X = UserControl.ScaleX(X, vbContainerPosition, vbPixels)
  1679.         p.Y = UserControl.ScaleY(Y, vbContainerPosition, vbPixels)
  1680.         ClientToScreen ListBoxHandle, p
  1681.         Index = LBItemFromPt(ListBoxHandle, p.X, p.Y, 0)
  1682.         If Index > -1 Then
  1683.             Dim RC As RECT
  1684.             SendMessage ListBoxHandle, LB_GETITEMRECT, Index, ByVal VarPtr(RC)
  1685.             After = CBool(CLng(UserControl.ScaleY(Y, vbContainerPosition, vbPixels)) > (RC.Top + ((RC.Bottom - RC.Top) / 2)))
  1686.         End If
  1687.         HitTestInsertMark = Index
  1688.     End If
  1689. End Function

  1690. Public Function FindItem(ByVal Text As String, Optional ByVal Index As Long = -1, Optional ByVal Partial As Boolean) As Long
  1691.     If ListBoxHandle <> 0 Then
  1692.         If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&) = LB_ERR Or Index = -1 Then
  1693.             If Partial = True Then
  1694.                 FindItem = SendMessage(ListBoxHandle, LB_FINDSTRING, Index, ByVal StrPtr(Text))
  1695.             Else
  1696.                 FindItem = SendMessage(ListBoxHandle, LB_FINDSTRINGEXACT, Index, ByVal StrPtr(Text))
  1697.             End If
  1698.         Else
  1699.             ERR.Raise 381
  1700.         End If
  1701.     End If
  1702. End Function

  1703. Public Property Get InsertMark(Optional ByRef After As Boolean) As Long
  1704.     InsertMark = ListBoxInsertMark
  1705.     After = ListBoxInsertMarkAfter
  1706. End Property

  1707. Public Property Let InsertMark(Optional ByRef After As Boolean, ByVal Value As Long)
  1708.     If ListBoxInsertMark = Value And ListBoxInsertMarkAfter = After Then Exit Property
  1709.     If ListBoxHandle <> 0 Then
  1710.         If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Value, ByVal 0&) = LB_ERR Or Value = -1 Then
  1711.             If ListBoxInsertMark > -1 Then Call InvalidateInsertMark
  1712.             ListBoxInsertMark = Value
  1713.             ListBoxInsertMarkAfter = After
  1714.             If ListBoxInsertMark > -1 Then Call InvalidateInsertMark
  1715.         Else
  1716.             ERR.Raise 381
  1717.         End If
  1718.     End If
  1719. End Property

  1720. Public Property Get OptionIndex() As Long
  1721.     OptionIndex = ListBoxOptionIndex
  1722. End Property

  1723. Public Property Let OptionIndex(ByVal Value As Long)
  1724.     If ListBoxHandle <> 0 Then
  1725.         If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Value, ByVal 0&) = LB_ERR Or Value = -1 Then
  1726.             If PropStyle = LstStyleOption Then
  1727.                 If Value > -1 Then
  1728.                     Me.ItemChecked(Value) = True
  1729.                 Else
  1730.                     If ListBoxOptionIndex > -1 Then Me.ItemChecked(ListBoxOptionIndex) = False
  1731.                 End If
  1732.             End If
  1733.         Else
  1734.             ERR.Raise 381
  1735.         End If
  1736.     End If
  1737. End Property

  1738. Public Property Get OLEDraggedItem() As Long
  1739. OLEDraggedItem = ListBoxDragIndex - 1
  1740. End Property

  1741. Public Function GetIdealHorizontalExtent() As Single
  1742.     If ListBoxHandle <> 0 Then
  1743.         Dim Count As Long
  1744.         Count = SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&)
  1745.         If Count > 0 Then
  1746.             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
  1747.             GetWindowRect ListBoxHandle, RC(0)
  1748.             GetClientRect ListBoxHandle, RC(1)
  1749.             If (GetWindowLong(ListBoxHandle, GWL_STYLE) And WS_VSCROLL) = WS_VSCROLL Then
  1750.                 Const SM_CXVSCROLL As Long = 2
  1751.                 ScrollWidth = GetSystemMetrics(SM_CXVSCROLL)
  1752.             End If
  1753.             hDC = GetDC(ListBoxHandle)
  1754.             SelectObject hDC, ListBoxFontHandle
  1755.             For i = 0 To Count - 1
  1756.                 Length = SendMessage(ListBoxHandle, LB_GETTEXTLEN, i, ByVal 0&)
  1757.                 If Not Length = LB_ERR Then
  1758.                     Text = String(Length, vbNullChar)
  1759.                     SendMessage ListBoxHandle, LB_GETTEXT, i, ByVal StrPtr(Text)
  1760.                     GetTextExtentPoint32 hDC, ByVal StrPtr(Text), Length, Size
  1761.                     If (Size.cx - ScrollWidth) > cx Then cx = (Size.cx - ScrollWidth)
  1762.                 End If
  1763.             Next i
  1764.             ReleaseDC ListBoxHandle, hDC
  1765.             If cx > 0 Then GetIdealHorizontalExtent = UserControl.ScaleX(cx + ((RC(0).Right - RC(0).Left) - (RC(1).Right - RC(1).Left)), vbPixels, vbContainerSize)
  1766.         End If
  1767.     End If
  1768. End Function

  1769. Public Function SelectItem(ByVal Text As String, Optional ByVal Index As Long = -1) As Long
  1770.     If ListBoxHandle <> 0 Then
  1771.         If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&) = LB_ERR Or Index = -1 Then
  1772.             SelectItem = SendMessage(ListBoxHandle, LB_SELECTSTRING, Index, ByVal StrPtr(Text))
  1773.         Else
  1774.             ERR.Raise 381
  1775.         End If
  1776.     End If
  1777. End Function

  1778. Private Sub SetItemCheck(Optional ByVal Index As Long = LB_ERR)
  1779.     If ListBoxHandle <> 0 Then
  1780.         If Index = LB_ERR Then Index = SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&)
  1781.         If Not Index = LB_ERR Then
  1782.             If Index <= (ListBoxItemCheckedCount - 1) Then
  1783.                 Dim Changed As Boolean
  1784.                 If PropStyle = LstStyleCheckbox Then
  1785.                     Changed = True
  1786.                 ElseIf PropStyle = LstStyleOption Then
  1787.                     Changed = CBool(ListBoxOptionIndex <> Index)
  1788.                 End If
  1789.                 If Changed = True Then
  1790.                     Dim Cancel As Boolean
  1791.                     RaiseEvent ItemBeforeCheck(Index, Cancel)
  1792.                     If Cancel = False Then
  1793.                         Dim RC As RECT
  1794.                         If PropStyle = LstStyleCheckbox Then
  1795.                             Select Case ListBoxItemChecked(Index + 1)
  1796.                             Case vbChecked
  1797.                                 ListBoxItemChecked(Index + 1) = vbUnchecked
  1798.                             Case Else
  1799.                                 ListBoxItemChecked(Index + 1) = vbChecked
  1800.                             End Select
  1801.                         ElseIf PropStyle = LstStyleOption Then
  1802.                             If ListBoxOptionIndex > -1 Then
  1803.                                 SendMessage ListBoxHandle, LB_GETITEMRECT, ListBoxOptionIndex, ByVal VarPtr(RC)
  1804.                                 InvalidateRect ListBoxHandle, RC, 0
  1805.                             End If
  1806.                             ListBoxOptionIndex = Index
  1807.                         End If
  1808.                         SendMessage ListBoxHandle, LB_GETITEMRECT, Index, ByVal VarPtr(RC)
  1809.                         InvalidateRect ListBoxHandle, RC, 0
  1810.                         RaiseEvent ItemCheck(Index)
  1811.                     End If
  1812.                 End If
  1813.             End If
  1814.         End If
  1815.     End If
  1816. End Sub

  1817. Private Function CheckTopIndex() As Boolean
  1818.     Dim TopIndex As Long
  1819.     If ListBoxHandle <> 0 Then TopIndex = SendMessage(ListBoxHandle, LB_GETTOPINDEX, 0, ByVal 0&)
  1820.     If TopIndex <> ListBoxTopIndex Then
  1821.         ListBoxTopIndex = TopIndex
  1822.         If ListBoxInsertMark > -1 Then Call InvalidateInsertMark
  1823.         RaiseEvent Scroll
  1824.         CheckTopIndex = True
  1825.     End If
  1826. End Function

  1827. Private Sub InvalidateInsertMark()
  1828.     If ListBoxHandle <> 0 Then
  1829.         If SendMessage(ListBoxHandle, LB_GETTEXTLEN, ListBoxInsertMark, ByVal 0&) = LB_ERR Then Exit Sub
  1830.         Dim RC As RECT
  1831.         SendMessage ListBoxHandle, LB_GETITEMRECT, ListBoxInsertMark, ByVal VarPtr(RC)
  1832.         If ListBoxInsertMarkAfter = False Then
  1833.             RC.Bottom = RC.Top + 1
  1834.             RC.Top = RC.Top - 1
  1835.         Else
  1836.             RC.Top = RC.Bottom - 1
  1837.             RC.Bottom = RC.Bottom + 1
  1838.         End If
  1839.         RC.Top = RC.Top - 2
  1840.         RC.Bottom = RC.Bottom + 2
  1841.         InvalidateRect ListBoxHandle, RC, 1
  1842.     End If
  1843. End Sub

  1844. Private Sub DrawInsertMark()
  1845.     If ListBoxHandle <> 0 Then
  1846.         If SendMessage(ListBoxHandle, LB_GETTEXTLEN, ListBoxInsertMark, ByVal 0&) = LB_ERR Then Exit Sub
  1847.         Dim RC As RECT, hRgn As Long, hDC As Long, Brush As Long, OldBrush As Long
  1848.         GetClientRect ListBoxHandle, RC
  1849.         hDC = GetDC(ListBoxHandle)
  1850.         If hDC <> 0 Then
  1851.             hRgn = CreateRectRgnIndirect(RC)
  1852.             If hRgn <> 0 Then ExtSelectClipRgn hDC, hRgn, RGN_COPY
  1853.             SendMessage ListBoxHandle, LB_GETITEMRECT, ListBoxInsertMark, ByVal VarPtr(RC)
  1854.             If ListBoxInsertMarkAfter = False Then
  1855.                 RC.Bottom = RC.Top + 1
  1856.                 RC.Top = RC.Top - 1
  1857.             Else
  1858.                 RC.Top = RC.Bottom - 1
  1859.                 RC.Bottom = RC.Bottom + 1
  1860.             End If
  1861.             Brush = CreateSolidBrush(WinColor(PropInsertMarkColor))
  1862.             If Brush <> 0 Then OldBrush = SelectObject(hDC, Brush)
  1863.             PatBlt hDC, RC.Left, RC.Top - 2, 1, 6, vbPatCopy
  1864.             PatBlt hDC, RC.Left + 1, RC.Top - 1, 1, 4, vbPatCopy
  1865.             PatBlt hDC, RC.Left + 2, RC.Top, RC.Right - RC.Left - 2, RC.Bottom - RC.Top, vbPatCopy
  1866.             PatBlt hDC, RC.Right - 2, RC.Top - 1, 1, 4, vbPatCopy
  1867.             PatBlt hDC, RC.Right - 1, RC.Top - 2, 1, 6, vbPatCopy
  1868.             If OldBrush <> 0 Then SelectObject hDC, OldBrush
  1869.             If Brush <> 0 Then DeleteObject Brush
  1870.             If hRgn <> 0 Then
  1871.                 ExtSelectClipRgn hDC, 0, RGN_COPY
  1872.                 DeleteObject hRgn
  1873.             End If
  1874.             ReleaseDC ListBoxHandle, hDC
  1875.         End If
  1876.     End If
  1877. End Sub

  1878. 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
  1879.     Select Case dwRefData
  1880.     Case 1
  1881.         ISubclass_Message = WindowProcControl(hwnd, wMsg, wParam, lParam)
  1882.     Case 2
  1883.         ISubclass_Message = WindowProcUserControl(hwnd, wMsg, wParam, lParam)
  1884.     Case 3
  1885.         ISubclass_Message = WindowProcUserControlDesignMode(hwnd, wMsg, wParam, lParam)
  1886.     End Select
  1887. End Function

  1888. Private Function WindowProcControl(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  1889.     Select Case wMsg
  1890.     Case WM_SETFOCUS
  1891.         If wParam <> UserControl.hwnd Then SetFocusAPI UserControl.hwnd: Exit Function
  1892.         Call ActivateIPAO(Me)
  1893.     Case WM_KILLFOCUS
  1894.         Call DeActivateIPAO
  1895.     Case WM_KEYDOWN, WM_KEYUP, WM_SYSKEYDOWN, WM_SYSKEYUP
  1896.         Dim KeyCode As Integer
  1897.         KeyCode = wParam And &HFF&
  1898.         If wMsg = WM_KEYDOWN Or wMsg = WM_KEYUP Then
  1899.             If wMsg = WM_KEYDOWN Then
  1900.                 RaiseEvent KeyDown(KeyCode, GetShiftStateFromMsg())
  1901.                 If PropStyle <> LstStyleStandard And KeyCode = vbKeySpace Then Call SetItemCheck
  1902.             ElseIf wMsg = WM_KEYUP Then
  1903.                 RaiseEvent KeyUp(KeyCode, GetShiftStateFromMsg())
  1904.             End If
  1905.             ListBoxCharCodeCache = ComCtlsPeekCharCode(hwnd)
  1906.         ElseIf wMsg = WM_SYSKEYDOWN Then
  1907.             RaiseEvent KeyDown(KeyCode, GetShiftStateFromMsg())
  1908.         ElseIf wMsg = WM_SYSKEYUP Then
  1909.             RaiseEvent KeyUp(KeyCode, GetShiftStateFromMsg())
  1910.         End If
  1911.         wParam = KeyCode
  1912.     Case WM_CHAR
  1913.         Dim KeyChar As Integer
  1914.         If ListBoxCharCodeCache <> 0 Then
  1915.             KeyChar = CUIntToInt(ListBoxCharCodeCache And &HFFFF&)
  1916.             ListBoxCharCodeCache = 0
  1917.         Else
  1918.             KeyChar = CUIntToInt(wParam And &HFFFF&)
  1919.         End If
  1920.         RaiseEvent KeyPress(KeyChar)
  1921.         wParam = CIntToUInt(KeyChar)
  1922.     Case WM_UNICHAR
  1923.         If wParam = UNICODE_NOCHAR Then WindowProcControl = 1 Else SendMessage hwnd, WM_CHAR, wParam, ByVal lParam
  1924.         Exit Function
  1925.     Case WM_IME_CHAR
  1926.         SendMessage hwnd, WM_CHAR, wParam, ByVal lParam
  1927.         Exit Function
  1928.     Case WM_MOUSEACTIVATE
  1929.         Static InProc As Boolean
  1930.         If ListBoxTopDesignMode = False And GetFocus() <> ListBoxHandle Then
  1931.             If InProc = True Or LoWord(lParam) = HTBORDER Then WindowProcControl = MA_ACTIVATEANDEAT: Exit Function
  1932.             Select Case HiWord(lParam)
  1933.             Case WM_LBUTTONDOWN
  1934.                 On Error Resume Next
  1935.                 With UserControl
  1936.                     If .Extender.CausesValidation = True Then
  1937.                         InProc = True
  1938.                         Call ComCtlsTopParentValidateControls(Me)
  1939.                         InProc = False
  1940.                         If ERR.Number = 380 Then
  1941.                             WindowProcControl = MA_ACTIVATEANDEAT
  1942.                         Else
  1943.                             SetFocusAPI .hwnd
  1944.                             WindowProcControl = MA_NOACTIVATE
  1945.                         End If
  1946.                     Else
  1947.                         SetFocusAPI .hwnd
  1948.                         WindowProcControl = MA_NOACTIVATE
  1949.                     End If
  1950.                 End With
  1951.                 On Error GoTo 0
  1952.                 Exit Function
  1953.             End Select
  1954.         End If
  1955.     Case WM_SETCURSOR
  1956.         If LoWord(lParam) = HTCLIENT Then
  1957.             If MousePointerID(PropMousePointer) <> 0 Then
  1958.                 SetCursor LoadCursor(0, MousePointerID(PropMousePointer))
  1959.                 WindowProcControl = 1
  1960.                 Exit Function
  1961.             ElseIf PropMousePointer = 99 Then
  1962.                 If Not PropMouseIcon Is Nothing Then
  1963.                     SetCursor PropMouseIcon.Handle
  1964.                     WindowProcControl = 1
  1965.                     Exit Function
  1966.                 End If
  1967.             End If
  1968.         End If
  1969.     Case WM_LBUTTONDOWN
  1970.         Dim Index As Long, IgnoreItemCheck As Boolean, P1 As POINTAPI, RC As RECT
  1971.         P1.X = Get_X_lParam(lParam)
  1972.         P1.Y = Get_Y_lParam(lParam)
  1973.         ClientToScreen ListBoxHandle, P1
  1974.         If PropOLEDragMode = vbOLEDragAutomatic Then
  1975.             Index = LBItemFromPt(ListBoxHandle, P1.X, P1.Y, 0)
  1976.             If Index > -1 Then
  1977.                 If SendMessage(ListBoxHandle, LB_GETSEL, Index, ByVal 0&) > 0 Then
  1978.                     If DragDetect(ListBoxHandle, CUIntToInt(P1.X And &HFFFF&), CUIntToInt(P1.Y And &HFFFF&)) <> 0 Then
  1979.                         ListBoxDragIndexBuffer = Index + 1
  1980.                         Me.OLEDrag
  1981.                         ListBoxDragIndexBuffer = 0
  1982.                     Else
  1983.                         If PropStyle <> LstStyleStandard Then
  1984.                             If Index <> SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&) Then
  1985.                                 SendMessage ListBoxHandle, LB_GETITEMRECT, Index, ByVal VarPtr(RC)
  1986.                                 If PropRightToLeft = False Then
  1987.                                     IgnoreItemCheck = CBool(Get_X_lParam(lParam) >= (RC.Left + ListBoxStateImageSize))
  1988.                                 Else
  1989.                                     IgnoreItemCheck = CBool(Get_X_lParam(lParam) < (RC.Right - ListBoxStateImageSize))
  1990.                                 End If
  1991.                             End If
  1992.                         End If
  1993.                         WindowProcControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
  1994.                         If PropStyle <> LstStyleStandard Then If IgnoreItemCheck = False Then Call SetItemCheck(Index)
  1995.                         RaiseEvent MouseDown(vbLeftButton, GetShiftStateFromParam(wParam), UserControl.ScaleX(P1.X, vbPixels, vbTwips), UserControl.ScaleY(P1.Y, vbPixels, vbTwips))
  1996.                         ReleaseCapture
  1997.                     End If
  1998.                     Exit Function
  1999.                 ElseIf PropStyle <> LstStyleStandard Then
  2000.                     If Index <> SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&) Then
  2001.                         SendMessage ListBoxHandle, LB_GETITEMRECT, Index, ByVal VarPtr(RC)
  2002.                         If PropRightToLeft = False Then
  2003.                             IgnoreItemCheck = CBool(Get_X_lParam(lParam) >= (RC.Left + ListBoxStateImageSize))
  2004.                         Else
  2005.                             IgnoreItemCheck = CBool(Get_X_lParam(lParam) < (RC.Right - ListBoxStateImageSize))
  2006.                         End If
  2007.                     End If
  2008.                     WindowProcControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
  2009.                     RaiseEvent MouseDown(vbLeftButton, GetShiftStateFromParam(wParam), UserControl.ScaleX(P1.X, vbPixels, vbTwips), UserControl.ScaleY(P1.Y, vbPixels, vbTwips))
  2010.                     If IgnoreItemCheck = False Then Call SetItemCheck(Index)
  2011.                     Exit Function
  2012.                 End If
  2013.             End If
  2014.         ElseIf PropStyle <> LstStyleStandard Then
  2015.             Index = LBItemFromPt(ListBoxHandle, P1.X, P1.Y, 0)
  2016.             If Index > -1 Then
  2017.                 If Index <> SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&) Then
  2018.                     SendMessage ListBoxHandle, LB_GETITEMRECT, Index, ByVal VarPtr(RC)
  2019.                     If PropRightToLeft = False Then
  2020.                         IgnoreItemCheck = CBool(Get_X_lParam(lParam) >= (RC.Left + ListBoxStateImageSize))
  2021.                     Else
  2022.                         IgnoreItemCheck = CBool(Get_X_lParam(lParam) < (RC.Right - ListBoxStateImageSize))
  2023.                     End If
  2024.                 End If
  2025.                 WindowProcControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
  2026.                 RaiseEvent MouseDown(vbLeftButton, GetShiftStateFromParam(wParam), UserControl.ScaleX(P1.X, vbPixels, vbTwips), UserControl.ScaleY(P1.Y, vbPixels, vbTwips))
  2027.                 If IgnoreItemCheck = False Then Call SetItemCheck(Index)
  2028.                 Exit Function
  2029.             End If
  2030.         End If
  2031.     Case WM_CONTEXTMENU
  2032.         If wParam = ListBoxHandle Then
  2033.             Dim P2 As POINTAPI
  2034.             P2.X = Get_X_lParam(lParam)
  2035.             P2.Y = Get_Y_lParam(lParam)
  2036.             If P2.X > 0 And P2.Y > 0 Then
  2037.                 ScreenToClient ListBoxHandle, P2
  2038.                 RaiseEvent ContextMenu(UserControl.ScaleX(P2.X, vbPixels, vbContainerPosition), UserControl.ScaleY(P2.Y, vbPixels, vbContainerPosition))
  2039.             ElseIf P2.X = -1 And P2.Y = -1 Then
  2040.                 ' If the user types SHIFT + F10 then the X and Y coordinates are -1.
  2041.                 RaiseEvent ContextMenu(-1, -1)
  2042.             End If
  2043.         End If
  2044.     Case WM_HSCROLL, WM_VSCROLL
  2045.         If Not (wMsg = WM_HSCROLL And PropMultiColumn = False) Then
  2046.             Select Case LoWord(wParam)
  2047.             Case SB_THUMBPOSITION, SB_THUMBTRACK
  2048.                 ' HiWord carries only 16 bits of scroll box position data.
  2049.                 ' Below workaround will circumvent the 16-bit barrier by using the 32-bit GetScrollInfo function.
  2050.                 Dim dwStyle As Long
  2051.                 dwStyle = GetWindowLong(ListBoxHandle, GWL_STYLE)
  2052.                 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
  2053.                     Dim SCI As SCROLLINFO, wBar As Long, PrevPos As Long
  2054.                     SCI.cbSize = LenB(SCI)
  2055.                     SCI.fMask = SIF_POS Or SIF_TRACKPOS
  2056.                     If wMsg = WM_HSCROLL Then
  2057.                         wBar = SB_HORZ
  2058.                     ElseIf wMsg = WM_VSCROLL Then
  2059.                         wBar = SB_VERT
  2060.                     End If
  2061.                     GetScrollInfo ListBoxHandle, wBar, SCI
  2062.                     PrevPos = SCI.nPos
  2063.                     Select Case LoWord(wParam)
  2064.                     Case SB_THUMBPOSITION
  2065.                         SCI.nPos = SCI.nTrackPos
  2066.                     Case SB_THUMBTRACK
  2067.                         If PropScrollTrack = True Then SCI.nPos = SCI.nTrackPos
  2068.                     End Select
  2069.                     If PrevPos <> SCI.nPos Then
  2070.                         If wMsg = WM_HSCROLL And PropMultiColumn = True Then SCI.nPos = SCI.nPos * Me.ItemsPerColumn
  2071.                         ' SetScrollInfo function not needed as LB_SETTOPINDEX itself will do the scrolling.
  2072.                         SendMessage ListBoxHandle, LB_SETTOPINDEX, SCI.nPos, ByVal 0&
  2073.                     End If
  2074.                     WindowProcControl = 0
  2075.                     Exit Function
  2076.                 End If
  2077.             End Select
  2078.         End If
  2079.     End Select
  2080.     WindowProcControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
  2081.     Select Case wMsg
  2082.     Case WM_LBUTTONDOWN, WM_MBUTTONDOWN, WM_RBUTTONDOWN, WM_MOUSEMOVE, WM_LBUTTONUP, WM_MBUTTONUP, WM_RBUTTONUP
  2083.         Dim X As Single
  2084.         Dim Y As Single
  2085.         X = UserControl.ScaleX(Get_X_lParam(lParam), vbPixels, vbTwips)
  2086.         Y = UserControl.ScaleY(Get_Y_lParam(lParam), vbPixels, vbTwips)
  2087.         Select Case wMsg
  2088.         Case WM_LBUTTONDOWN
  2089.             RaiseEvent MouseDown(vbLeftButton, GetShiftStateFromParam(wParam), X, Y)
  2090.         Case WM_MBUTTONDOWN
  2091.             RaiseEvent MouseDown(vbMiddleButton, GetShiftStateFromParam(wParam), X, Y)
  2092.         Case WM_RBUTTONDOWN
  2093.             RaiseEvent MouseDown(vbRightButton, GetShiftStateFromParam(wParam), X, Y)
  2094.         Case WM_MOUSEMOVE
  2095.             If (GetMouseStateFromParam(wParam) And vbLeftButton) = vbLeftButton Then
  2096.                 If CheckTopIndex() = False And ListBoxInsertMark > -1 Then Call InvalidateInsertMark
  2097.             End If
  2098.             If ListBoxMouseOver = False And PropMouseTrack = True Then
  2099.                 ListBoxMouseOver = True
  2100.                 RaiseEvent MouseEnter
  2101.                 Call ComCtlsRequestMouseLeave(hwnd)
  2102.             End If
  2103.             RaiseEvent MouseMove(GetMouseStateFromParam(wParam), GetShiftStateFromParam(wParam), X, Y)
  2104.         Case WM_LBUTTONUP, WM_MBUTTONUP, WM_RBUTTONUP
  2105.             Select Case wMsg
  2106.             Case WM_LBUTTONUP
  2107.                 RaiseEvent MouseUp(vbLeftButton, GetShiftStateFromParam(wParam), X, Y)
  2108.             Case WM_MBUTTONUP
  2109.                 RaiseEvent MouseUp(vbMiddleButton, GetShiftStateFromParam(wParam), X, Y)
  2110.             Case WM_RBUTTONUP
  2111.                 RaiseEvent MouseUp(vbRightButton, GetShiftStateFromParam(wParam), X, Y)
  2112.             End Select
  2113.         End Select
  2114.     Case WM_MOUSELEAVE
  2115.         If ListBoxMouseOver = True Then
  2116.             ListBoxMouseOver = False
  2117.             RaiseEvent MouseLeave
  2118.         End If
  2119.     Case WM_MOUSEWHEEL, WM_HSCROLL, WM_VSCROLL, LB_SETTOPINDEX
  2120.         If CheckTopIndex() = False And ListBoxInsertMark > -1 Then Call InvalidateInsertMark
  2121.     Case WM_PAINT
  2122.         If ListBoxInsertMark > -1 Then Call DrawInsertMark
  2123.     End Select
  2124. End Function

  2125. Private Function WindowProcUserControl(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  2126.     Select Case wMsg
  2127.     Case WM_COMMAND
  2128.         If lParam = ListBoxHandle Then
  2129.             Select Case HiWord(wParam)
  2130.             Case LBN_SELCHANGE
  2131.                 If CheckTopIndex() = False And ListBoxInsertMark > -1 Then Call InvalidateInsertMark
  2132.                 RaiseEvent Click
  2133.             Case LBN_SELCANCEL
  2134.                 If ListBoxInsertMark > -1 Then Call InvalidateInsertMark
  2135.                 RaiseEvent Click
  2136.             Case LBN_DBLCLK
  2137.                 RaiseEvent DblClick
  2138.             End Select
  2139.         End If
  2140.     Case WM_MEASUREITEM
  2141.         If PropDrawMode = LstDrawModeOwnerDrawVariable Then
  2142.             Dim MIS As MEASUREITEMSTRUCT
  2143.             CopyMemory MIS, ByVal lParam, LenB(MIS)
  2144.             If MIS.CtlType = ODT_LISTBOX And MIS.ItemID > -1 Then
  2145.                 With MIS
  2146.                     RaiseEvent ItemMeasure(.ItemID, .ItemHeight)
  2147.                 End With
  2148.                 CopyMemory ByVal lParam, MIS, LenB(MIS)
  2149.                 WindowProcUserControl = 1
  2150.                 Exit Function
  2151.             End If
  2152.         End If
  2153.     Case WM_DRAWITEM
  2154.         Dim DIS As DRAWITEMSTRUCT
  2155.         CopyMemory DIS, ByVal lParam, LenB(DIS)
  2156.         If DIS.CtlType = ODT_LISTBOX And DIS.hWndItem = ListBoxHandle And DIS.ItemID > -1 Then
  2157.             If PropStyle <> LstStyleStandard Then
  2158.                 Dim BackColorBrush As Long, BackColorSelBrush As Long
  2159.                 BackColorBrush = CreateSolidBrush(WinColor(UserControl.BackColor))
  2160.                 If (DIS.ItemState And ODS_SELECTED) = ODS_SELECTED And PropAllowSelection = True Then BackColorSelBrush = CreateSolidBrush(WinColor(vbHighlight))
  2161.                 Dim RC As RECT
  2162.                 With DIS.RCItem
  2163.                     If PropRightToLeft = False Then
  2164.                         SetRect RC, .Left + 1, .Top + 1, .Left + ListBoxStateImageSize - 1, .Bottom - 1
  2165.                         .Left = .Left + ListBoxStateImageSize
  2166.                     Else
  2167.                         SetRect RC, .Right - ListBoxStateImageSize + 1, .Top + 1, .Right - 1, .Bottom - 1
  2168.                         .Right = .Right - ListBoxStateImageSize
  2169.                     End If
  2170.                 End With
  2171.                 If BackColorSelBrush <> 0 Then
  2172.                     FillRect DIS.hDC, DIS.RCItem, BackColorSelBrush
  2173.                     DeleteObject BackColorSelBrush
  2174.                 Else
  2175.                     FillRect DIS.hDC, DIS.RCItem, BackColorBrush
  2176.                 End If
  2177.                 FillRect DIS.hDC, RC, BackColorBrush
  2178.                 DeleteObject BackColorBrush
  2179.                
  2180.                 #If ImplementThemedButton = True Then
  2181.                     
  2182.                     Dim Theme As Long
  2183.                     If EnabledVisualStyles() = True And PropVisualStyles = True Then Theme = OpenThemeData(ListBoxHandle, StrPtr("Button"))
  2184.                     If Theme <> 0 Then
  2185.                         Dim ButtonPart As Long, CheckState As Long
  2186.                         If PropStyle = LstStyleCheckbox Then
  2187.                             ButtonPart = BP_CHECKBOX
  2188.                             If Not (DIS.ItemState And ODS_DISABLED) = ODS_DISABLED Then
  2189.                                 CheckState = CBS_UNCHECKEDNORMAL
  2190.                             Else
  2191.                                 CheckState = CBS_UNCHECKEDDISABLED
  2192.                             End If
  2193.                             If DIS.ItemID <= (ListBoxItemCheckedCount - 1) Then
  2194.                                 If ListBoxItemChecked(DIS.ItemID + 1) = vbChecked Then
  2195.                                     If Not (DIS.ItemState And ODS_DISABLED) = ODS_DISABLED Then
  2196.                                         CheckState = CBS_CHECKEDNORMAL
  2197.                                     Else
  2198.                                         CheckState = CBS_CHECKEDDISABLED
  2199.                                     End If
  2200.                                 End If
  2201.                             End If
  2202.                         ElseIf PropStyle = LstStyleOption Then
  2203.                             ButtonPart = BP_RADIOBUTTON
  2204.                             If Not (DIS.ItemState And ODS_DISABLED) = ODS_DISABLED Then
  2205.                                 CheckState = RBS_UNCHECKEDNORMAL
  2206.                             Else
  2207.                                 CheckState = RBS_UNCHECKEDDISABLED
  2208.                             End If
  2209.                             If DIS.ItemID <= (ListBoxItemCheckedCount - 1) Then
  2210.                                 If ListBoxOptionIndex = DIS.ItemID Then
  2211.                                     If Not (DIS.ItemState And ODS_DISABLED) = ODS_DISABLED Then
  2212.                                         CheckState = CBS_CHECKEDNORMAL
  2213.                                     Else
  2214.                                         CheckState = CBS_CHECKEDDISABLED
  2215.                                     End If
  2216.                                 End If
  2217.                             End If
  2218.                         End If
  2219.                         If IsThemeBackgroundPartiallyTransparent(Theme, ButtonPart, CheckState) <> 0 Then DrawThemeParentBackground DIS.hWndItem, DIS.hDC, RC
  2220.                         DrawThemeBackground Theme, DIS.hDC, ButtonPart, CheckState, RC, RC
  2221.                         CloseThemeData Theme
  2222.                     Else
  2223.                         Dim Flags As Long
  2224.                         Flags = DFCS_FLAT
  2225.                         If (DIS.ItemState And ODS_DISABLED) = ODS_DISABLED Then Flags = Flags Or DFCS_INACTIVE
  2226.                         If PropStyle = LstStyleCheckbox Then
  2227.                             Flags = Flags Or DFCS_BUTTONCHECK
  2228.                             If DIS.ItemID <= (ListBoxItemCheckedCount - 1) Then
  2229.                                 If ListBoxItemChecked(DIS.ItemID + 1) = vbChecked Then Flags = Flags Or DFCS_CHECKED
  2230.                             End If
  2231.                         ElseIf PropStyle = LstStyleOption Then
  2232.                             Flags = Flags Or DFCS_BUTTONRADIO
  2233.                             If DIS.ItemID <= (ListBoxItemCheckedCount - 1) Then
  2234.                                 If ListBoxOptionIndex = DIS.ItemID Then Flags = Flags Or DFCS_CHECKED
  2235.                             End If
  2236.                         End If
  2237.                         DrawFrameControl DIS.hDC, RC, DFC_BUTTON, Flags
  2238.                     End If
  2239.                     
  2240.                 #Else
  2241.                     
  2242.                     Dim Flags As Long
  2243.                     Flags = DFCS_FLAT
  2244.                     If (DIS.ItemState And ODS_DISABLED) = ODS_DISABLED Then Flags = Flags Or DFCS_INACTIVE
  2245.                     If PropStyle = LstStyleCheckbox Then
  2246.                         Flags = Flags Or DFCS_BUTTONCHECK
  2247.                         If DIS.ItemID <= (ListBoxItemCheckedCount - 1) Then
  2248.                             If ListBoxItemChecked(DIS.ItemID + 1) = vbChecked Then Flags = Flags Or DFCS_CHECKED
  2249.                         End If
  2250.                     ElseIf PropStyle = LstStyleOption Then
  2251.                         Flags = Flags Or DFCS_BUTTONRADIO
  2252.                         If DIS.ItemID <= (ListBoxItemCheckedCount - 1) Then
  2253.                             If ListBoxOptionIndex = DIS.ItemID Then Flags = Flags Or DFCS_CHECKED
  2254.                         End If
  2255.                     End If
  2256.                     DrawFrameControl DIS.hDC, RC, DFC_BUTTON, Flags
  2257.                     
  2258.                 #End If
  2259.                
  2260.                 Dim Length As Long
  2261.                 Length = SendMessage(ListBoxHandle, LB_GETTEXTLEN, DIS.ItemID, ByVal 0&)
  2262.                 If Not Length = LB_ERR Then
  2263.                     Dim Text As String
  2264.                     Text = String(Length, vbNullChar)
  2265.                     SendMessage ListBoxHandle, LB_GETTEXT, DIS.ItemID, ByVal StrPtr(Text)
  2266.                     Dim OldTextAlign As Long, OldBkMode As Long, OldTextColor As Long
  2267.                     If PropRightToLeft = True Then OldTextAlign = SetTextAlign(DIS.hDC, TA_RTLREADING Or TA_RIGHT)
  2268.                     OldBkMode = SetBkMode(DIS.hDC, 1)
  2269.                     If (DIS.ItemState And ODS_DISABLED) = ODS_DISABLED Then
  2270.                         OldTextColor = SetTextColor(DIS.hDC, WinColor(vbGrayText))
  2271.                     ElseIf (DIS.ItemState And ODS_SELECTED) = ODS_SELECTED And PropAllowSelection = True Then
  2272.                         OldTextColor = SetTextColor(DIS.hDC, WinColor(vbHighlightText))
  2273.                     Else
  2274.                         OldTextColor = SetTextColor(DIS.hDC, WinColor(Me.ForeColor))
  2275.                     End If
  2276.                     If PropRightToLeft = False Then
  2277.                         TextOut DIS.hDC, DIS.RCItem.Left + (1 * PixelsPerDIP_X()), DIS.RCItem.Top, StrPtr(Text), Length
  2278.                     Else
  2279.                         TextOut DIS.hDC, DIS.RCItem.Right - (1 * PixelsPerDIP_X()), DIS.RCItem.Top, StrPtr(Text), Length
  2280.                     End If
  2281.                     SetBkMode DIS.hDC, OldBkMode
  2282.                     SetTextColor DIS.hDC, OldTextColor
  2283.                     If PropRightToLeft = True Then SetTextAlign DIS.hDC, OldTextAlign
  2284.                 End If
  2285.                 If (DIS.ItemState And ODS_FOCUS) = ODS_FOCUS Then DrawFocusRect DIS.hDC, DIS.RCItem
  2286.             Else
  2287.                 With DIS
  2288.                     RaiseEvent ItemDraw(.ItemID, .ItemAction, .ItemState, .hDC, .RCItem.Left, .RCItem.Top, .RCItem.Right, .RCItem.Bottom)
  2289.                 End With
  2290.             End If
  2291.             WindowProcUserControl = 1
  2292.             Exit Function
  2293.         End If
  2294.     End Select
  2295.     WindowProcUserControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
  2296.     If wMsg = WM_SETFOCUS Then SetFocusAPI ListBoxHandle
  2297. End Function

  2298. Private Function WindowProcUserControlDesignMode(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  2299.     If wMsg = WM_DRAWITEM Then
  2300.         WindowProcUserControlDesignMode = WindowProcUserControl(hwnd, wMsg, wParam, lParam)
  2301.         Exit Function
  2302.     End If
  2303.     WindowProcUserControlDesignMode = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
  2304.     Select Case wMsg
  2305.     Case WM_DESTROY, WM_NCDESTROY
  2306.         Call ComCtlsRemoveSubclass(hwnd)
  2307.     Case WM_STYLECHANGED
  2308.         Dim dwStyleOld As Long, dwStyleNew As Long
  2309.         CopyMemory dwStyleOld, ByVal lParam, 4
  2310.         CopyMemory dwStyleNew, ByVal UnsignedAdd(lParam, 4), 4
  2311.         If dwStyleOld = dwStyleNew Then Call ComCtlsRemoveSubclass(hwnd)
  2312.     End Select
  2313. End Function
复制代码
Sbutton.ctl
  1. Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
  2. Private Declare Function ReleaseCapture Lib "user32" () As Long

  3. '事件************************************
  4. Public Event Click() '鼠标单击
  5. Public Event Hover() '鼠标悬停
  6. Public Event MouseLeave() '鼠标离开

  7. '常量************************************
  8. Const FORECOLORUNABLE As Long = &H80000011 '不可用时的文本颜色
  9. Const BACKCOLORUNABLE As Long = &H8000000F '不可用时的背景颜色
  10. Const BORDERCOLORUNABLE As Long = &H80000015 '不可用时的边框颜色

  11. '枚举************************************
  12. Public Enum pBorderStyle_SButton
  13.     无边框
  14.     有边框
  15. End Enum

  16. Public Enum pState_SButton
  17.     mNormal
  18.     mHover
  19.     mClick
  20. End Enum

  21. '存储的属性值***************************
  22. Private cBackColorClick As OLE_COLOR '鼠标单击时的背景颜色
  23. Private cBackColorHover As OLE_COLOR '鼠标悬停时的背景颜色
  24. Private cBackColorNormal As OLE_COLOR '默认状态下的背景颜色
  25. Private cBorderColorClick As OLE_COLOR '鼠标单击时的边框颜色
  26. Private cBorderColorHover As OLE_COLOR '鼠标悬停时的边框颜色
  27. Private cBorderColorNormal As OLE_COLOR '默认状态下的边框颜色
  28. Private cBorderStyle As pBorderStyle_SButton '边框样式,0 - 无边框;1 - 有边框
  29. Private cCaption As String '标题
  30. Private cEnabled As Boolean '有效性
  31. Private cFont As Font   '字体样式
  32. Private cForeColorClick As OLE_COLOR '鼠标单击时的文本颜色
  33. Private cForeColorHover As OLE_COLOR '鼠标悬停时的文本颜色
  34. Private cForeColorNormal As OLE_COLOR '默认状态下的文本颜色

  35. Private cState As pState_SButton '鼠标状态

  36. '重设控件:控件值改变时执行
  37. Private Sub RedrawControl()
  38. Select Case cState
  39.     Case mNormal
  40.         UserControl.BackColor = cBackColorNormal
  41.         Shape1.BorderColor = cBorderColorNormal
  42.         Label1.ForeColor = cForeColorNormal
  43.     Case mHover
  44.         UserControl.BackColor = cBackColorHover
  45.         Shape1.BorderColor = cBorderColorHover
  46.         Label1.ForeColor = cForeColorHover
  47.     Case mClick
  48.         UserControl.BackColor = cBackColorClick
  49.         Shape1.BorderColor = cBorderColorClick
  50.         Label1.ForeColor = cForeColorClick
  51. End Select

  52. Shape1.Visible = (cBorderStyle = 有边框)
  53. Set Label1.Font = cFont
  54. Label1.Caption = cCaption
  55. UserControl.Enabled = cEnabled
  56. Label1.Move UserControl.Width / 2 - Label1.Width / 2, UserControl.Height / 2 - Label1.Height / 2 '居中标签
  57. If cEnabled = False Then
  58.     UserControl.BackColor = BACKCOLORUNABLE
  59.     Label1.ForeColor = FORECOLORUNABLE
  60.     Shape1.BorderColor = BORDERCOLORUNABLE
  61. End If
  62. Shape1.Move 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight

  63. End Sub

  64. '响应的事件处理************************
  65. Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  66. If cEnabled = False Then Exit Sub
  67. If cEnabled = False Then Exit Sub
  68. If Button = 1 Then
  69.     RaiseEvent Click
  70.     cState = mClick
  71.     RedrawControl
  72. End If
  73. End Sub

  74. Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  75. If cEnabled = False Then Exit Sub
  76. If Button <> 0 Then Exit Sub
  77. If cState = mNormal Then
  78.     cState = mHover
  79.     RedrawControl
  80. End If
  81. RaiseEvent Hover
  82. End Sub

  83. Private Sub Label1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  84. If cEnabled = False Then Exit Sub
  85. cState = mHover
  86. RedrawControl
  87. End Sub

  88. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  89. If cEnabled = False Then Exit Sub
  90. If Button = 1 Then
  91.     RaiseEvent Click
  92.     cState = mClick
  93.     RedrawControl
  94. End If
  95. End Sub

  96. Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  97. If X >= 0 And X <= UserControl.Width And Y >= 0 And Y <= UserControl.Height Then
  98.     '移入
  99.     If cEnabled = False Then Exit Sub
  100.     If Button <> 0 Then Exit Sub
  101.     If cState = mNormal Then
  102.         cState = mHover
  103.         RedrawControl
  104.     End If
  105.     RaiseEvent Hover

  106.     SetCapture UserControl.hwnd
  107. Else
  108.     '移出
  109.     If cState <> mNormal Then cState = mNormal
  110.     RedrawControl
  111.     ReleaseCapture
  112. End If

  113. End Sub

  114. '属性的读写*****************************
  115. Public Property Get BackColorClick() As OLE_COLOR '获得鼠标按下时背景颜色
  116. BackColorClick = cBackColorClick
  117. End Property

  118. Public Property Let BackColorClick(ByVal nV As OLE_COLOR) '写入鼠标按下时背景颜色
  119. cBackColorClick = nV
  120. RedrawControl
  121. PropertyChanged "BackColorClick"
  122. End Property
  123. '██████████
  124. Public Property Get BackColorHover() As OLE_COLOR '获得鼠标悬停时背景颜色
  125. BackColorHover = cBackColorHover
  126. End Property

  127. Public Property Let BackColorHover(ByVal nV As OLE_COLOR) '写入鼠标悬停时背景颜色
  128. cBackColorHover = nV
  129. RedrawControl
  130. PropertyChanged "BackColorHover"
  131. End Property
  132. '██████████
  133. Public Property Get BackColorNormal() As OLE_COLOR '获得正常状态时背景颜色
  134. BackColorNormal = cBackColorNormal
  135. End Property

  136. Public Property Let BackColorNormal(ByVal nV As OLE_COLOR) '写入正常状态时背景颜色
  137. cBackColorNormal = nV
  138. RedrawControl
  139. PropertyChanged "BackColorNormal"
  140. End Property
  141. '██████████
  142. Public Property Get BorderColorClick() As OLE_COLOR '获得鼠标按下时边框颜色
  143. BorderColorClick = cBorderColorClick
  144. End Property

  145. Public Property Let BorderColorClick(ByVal nV As OLE_COLOR) '写入鼠标按下时边框颜色
  146. cBorderColorClick = nV
  147. RedrawControl
  148. PropertyChanged "BorderColorClick"
  149. End Property
  150. '██████████
  151. Public Property Get BorderColorHover() As OLE_COLOR '获得鼠标悬停时边框颜色
  152. BorderColorHover = cBorderColorHover
  153. End Property

  154. Public Property Let BorderColorHover(ByVal nV As OLE_COLOR) '写入鼠标悬停时边框颜色
  155. cBorderColorHover = nV
  156. RedrawControl
  157. PropertyChanged "BorderColorHover"
  158. End Property
  159. '██████████
  160. Public Property Get BorderColorNormal() As OLE_COLOR '获得正常状态时边框颜色
  161. BorderColorNormal = cBorderColorNormal
  162. End Property

  163. Public Property Let BorderColorNormal(ByVal nV As OLE_COLOR) '写入正常状态时边框颜色
  164. cBorderColorNormal = nV
  165. RedrawControl
  166. PropertyChanged "BorderColorNormal"
  167. End Property
  168. '██████████
  169. Public Property Get ForeColorClick() As OLE_COLOR '获得鼠标按下时文本颜色
  170. ForeColorClick = cForeColorClick
  171. End Property

  172. Public Property Let ForeColorClick(ByVal nV As OLE_COLOR) '写入鼠标按下时文本颜色
  173. cForeColorClick = nV
  174. RedrawControl
  175. PropertyChanged "ForeColorClick"
  176. End Property
  177. '██████████
  178. Public Property Get ForeColorHover() As OLE_COLOR '获得鼠标悬停时文本颜色
  179. ForeColorHover = cForeColorHover
  180. End Property

  181. Public Property Let ForeColorHover(ByVal nV As OLE_COLOR) '写入鼠标悬停时文本颜色
  182. cForeColorHover = nV
  183. RedrawControl
  184. PropertyChanged "ForeColorHover"
  185. End Property
  186. '██████████
  187. Public Property Get ForeColorNormal() As OLE_COLOR '获得正常状态时文本颜色
  188. ForeColorNormal = cForeColorNormal
  189. End Property

  190. Public Property Let ForeColorNormal(ByVal nV As OLE_COLOR) '写入正常状态时文本颜色
  191. cForeColorNormal = nV
  192. RedrawControl
  193. PropertyChanged "ForeColorNormal"
  194. End Property
  195. '██████████
  196. Public Property Get BorderStyle() As pBorderStyle_SButton    '获得边框样式
  197. BorderStyle = cBorderStyle
  198. End Property

  199. Public Property Let BorderStyle(ByVal nV As pBorderStyle_SButton) '写入边框样式
  200. cBorderStyle = nV
  201. RedrawControl
  202. PropertyChanged "BorderStyle"
  203. End Property
  204. '██████████
  205. Public Property Get Caption() As String    '获得文本
  206. Caption = cCaption
  207. End Property

  208. Public Property Let Caption(ByVal nV As String) '写入文本
  209. cCaption = nV
  210. RedrawControl
  211. PropertyChanged "Caption"
  212. End Property
  213. '██████████

  214. Public Property Get Font() As Font    '获得字体
  215. Set Font = cFont
  216. End Property

  217. Public Property Set Font(ByRef nF As Font) '写入字体
  218. Set cFont = nF
  219. Set Label1.Font = cFont
  220. RedrawControl
  221. PropertyChanged "Font"
  222. End Property
  223. '██████████
  224. Public Property Get Enabled() As Boolean      '获得有效性
  225. Enabled = cEnabled
  226. End Property

  227. Public Property Let Enabled(ByVal nV As Boolean)   '写入有效性
  228. cEnabled = nV
  229. RedrawControl
  230. PropertyChanged "Enabled"
  231. End Property
  232. '██████████

  233. '初始化控件*****************************
  234. Private Sub UserControl_Initialize()
  235. cBackColorClick = RGB(51, 153, 255)
  236. cBackColorHover = RGB(102, 204, 255)
  237. cBackColorNormal = RGB(51, 204, 255)
  238. cBorderColorClick = RGB(0, 0, 0)
  239. cBorderColorHover = RGB(0, 0, 0)
  240. cBorderColorNormal = RGB(0, 0, 0)
  241. cForeColorClick = RGB(255, 255, 255)
  242. cForeColorHover = RGB(255, 255, 255)
  243. cForeColorNormal = RGB(255, 255, 255)
  244. cBorderStyle = 无边框 '不显示边框
  245. cCaption = "SButton"
  246. cEnabled = True
  247. Set cFont = Label2.Font
  248. cState = mNormal
  249. RedrawControl
  250. End Sub


  251. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  252. If cEnabled = False Then Exit Sub
  253. cState = mHover
  254. RedrawControl
  255. End Sub

  256. '读取属性*******************************
  257. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  258. cBackColorClick = PropBag.ReadProperty("BackColorClick", RGB(51, 153, 255))
  259. cBackColorHover = PropBag.ReadProperty("BackColorHover", RGB(102, 204, 255))
  260. cBackColorNormal = PropBag.ReadProperty("BackColorNormal", RGB(51, 204, 255))
  261. cBorderColorClick = PropBag.ReadProperty("BorderColorClick", RGB(0, 0, 0))
  262. cBorderColorHover = PropBag.ReadProperty("BorderColorHover", RGB(0, 0, 0))
  263. cBorderColorNormal = PropBag.ReadProperty("BorderColorNormal", RGB(0, 0, 0))
  264. cBorderStyle = PropBag.ReadProperty("BorderStyle", pBorderStyle_SButton.无边框)
  265. cCaption = PropBag.ReadProperty("Caption", "SButton")
  266. cEnabled = PropBag.ReadProperty("Enabled", True)
  267. Set cFont = PropBag.ReadProperty("Font", Label2.Font)
  268. cForeColorClick = PropBag.ReadProperty("ForeColorClick", RGB(255, 255, 255))
  269. cForeColorHover = PropBag.ReadProperty("ForeColorHover", RGB(255, 255, 255))
  270. cForeColorNormal = PropBag.ReadProperty("ForeColorNormal", RGB(255, 255, 255))

  271. RedrawControl
  272. End Sub

  273. '写入属性*******************************
  274. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  275. Call PropBag.WriteProperty("BackColorClick", cBackColorClick, RGB(51, 153, 255))
  276. Call PropBag.WriteProperty("BackColorHover", cBackColorHover, RGB(102, 204, 255))
  277. Call PropBag.WriteProperty("BackColorNormal", cBackColorNormal, RGB(51, 204, 255))
  278. Call PropBag.WriteProperty("BorderColorClick", cBorderColorClick, RGB(0, 0, 0))
  279. Call PropBag.WriteProperty("BorderColorHover", cBorderColorHover, RGB(0, 0, 0))
  280. Call PropBag.WriteProperty("BorderColorNormal", cBorderColorNormal, RGB(0, 0, 0))
  281. Call PropBag.WriteProperty("BorderStyle", cBorderStyle, pBorderStyle_SButton.无边框)
  282. Call PropBag.WriteProperty("Caption", cCaption, "SButton")
  283. Call PropBag.WriteProperty("Enabled", cEnabled, True)
  284. Call PropBag.WriteProperty("Font", cFont, Label2.Font)
  285. Call PropBag.WriteProperty("ForeColorClick", cForeColorClick, RGB(255, 255, 255))
  286. Call PropBag.WriteProperty("ForeColorHover", cForeColorHover, RGB(255, 255, 255))
  287. Call PropBag.WriteProperty("ForeColorNormal", cForeColorNormal, RGB(255, 255, 255))

  288. End Sub

  289. '重置尺寸*******************************
  290. Private Sub UserControl_Resize()
  291. Label1.Move UserControl.Width / 2 - Label1.Width / 2, UserControl.Height / 2 - Label1.Height / 2 '居中标签
  292. Shape1.Move 0, 0, UserControl.Width, UserControl.Height
  293. RedrawControl
  294. End Sub
复制代码
SSwitch.ctl

  1. '属性声明
  2. Private cBackColorOff As OLE_COLOR                                              '关闭时的背景色
  3. Private cBackColorOn As OLE_COLOR                                               '开启时的背景色
  4. Private cEnabled As Boolean                                                     '有效性
  5. Private cValue As Boolean                                                       '值

  6. '事件声明
  7. Public Event Click()

  8. Private Sub Picture1_Click()
  9.     If cEnabled = False Then Exit Sub
  10.     cValue = Not cValue
  11.     RedrawControl
  12.     RaiseEvent Click
  13. End Sub

  14. Private Sub Picture2_Click()
  15.     If cEnabled = False Then Exit Sub
  16.     cValue = Not cValue
  17.     RedrawControl
  18.     RaiseEvent Click
  19. End Sub

  20. Private Sub UserControl_Click()
  21.     If cEnabled = False Then Exit Sub
  22.     cValue = Not cValue
  23.     RedrawControl
  24.     RaiseEvent Click
  25. End Sub

  26. Private Sub RedrawControl()
  27.     If cValue = True Then
  28.         Picture2.Left = Picture1.Width - 15 - Picture2.Width
  29.         Picture1.BackColor = cBackColorOn
  30.     Else
  31.         Picture2.Left = 15
  32.         Picture1.BackColor = cBackColorOff
  33.     End If
  34.     Shape1.BorderColor = Picture1.BackColor
  35.     Shape1.BorderStyle = 1
  36.     Picture2.BackColor = RGB(255, 255, 255)
  37. End Sub

  38. '初始化控件
  39. Private Sub UserControl_Initialize()
  40.     cValue = False
  41.     cBackColorOff = RGB(225, 225, 225)
  42.     cBackColorOn = RGB(51, 204, 255)
  43.     cBorderColor = RGB(225, 225, 225)
  44.     UserControl_Resize
  45.     cEnabled = True
  46.    
  47.     RedrawControl
  48. End Sub

  49. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  50.     cBackColorOff = PropBag.ReadProperty("BackColorOff", RGB(225, 225, 225))
  51.     cBackColorOn = PropBag.ReadProperty("BackColorOn", RGB(51, 204, 255))
  52.     cValue = PropBag.ReadProperty("Value", False)
  53.     cEnabled = PropBag.ReadProperty("Enabled", True)
  54.    
  55.     RedrawControl
  56. End Sub

  57. Private Sub UserControl_Resize()
  58.     Picture1.Move 0, 0, UserControl.Width, UserControl.Height
  59.     Shape1.Move 0, 0, Picture1.Width, Picture1.Height
  60.     Picture2.Top = 15
  61.     Picture2.Width = Picture1.Width / 2 - 15
  62.     Picture2.Height = Picture1.Height - 30
  63.     RedrawControl
  64. End Sub

  65. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  66.     Call PropBag.WriteProperty("BackColorOff", cBackColorOff, RGB(225, 225, 225))
  67.     Call PropBag.WriteProperty("BackColorOn", cBackColorOn, RGB(51, 204, 255))
  68.     Call PropBag.WriteProperty("Enabled", cEnabled, True)
  69.     Call PropBag.WriteProperty("Value", cValue, False)
  70. End Sub

  71. '属性的读写*****************************
  72. Public Property Get BackColorOff() As OLE_COLOR
  73.     BackColorOff = cBackColorOff
  74. End Property

  75. Public Property Let BackColorOff(ByVal nV As OLE_COLOR)
  76.     cBackColorOff = nV
  77.     RedrawControl
  78.     PropertyChanged "BackColorOff"
  79. End Property
  80. '██████████

  81. Public Property Get BackColorOn() As OLE_COLOR
  82.     BackColorOn = cBackColorOn
  83. End Property

  84. Public Property Let BackColorOn(ByVal nV As OLE_COLOR)
  85.     cBackColorOn = nV
  86.     RedrawControl
  87.     PropertyChanged "BackColorOn"
  88. End Property
  89. '██████████

  90. Public Property Get Enabled() As Boolean                                        '获得有效性
  91.     Enabled = cEnabled
  92. End Property

  93. Public Property Let Enabled(ByVal nV As Boolean)                                '写入有效性
  94.     cEnabled = nV
  95.     RedrawControl
  96.     PropertyChanged "Enabled"
  97. End Property
  98. '██████████

  99. Public Property Get Value() As Boolean                                          '获得值
  100.     Value = cValue
  101. End Property

  102. Public Property Let Value(ByVal nV As Boolean)                                  '写入值
  103.     cValue = nV
  104.     RedrawControl
  105.     PropertyChanged "Value"
  106. End Property
  107. '██████████
复制代码
TextBoxW
  1. Option Explicit
  2. #If False Then
  3. Private TxtCharacterCasingNormal, TxtCharacterCasingUpper, TxtCharacterCasingLower
  4. Private TxtIconNone, TxtIconInfo, TxtIconWarning, TxtIconError
  5. Private TxtNetAddressFormatNone, TxtNetAddressFormatDNSName, TxtNetAddressFormatIPv4, TxtNetAddressFormatIPv6
  6. Private TxtNetAddressTypeNone, TxtNetAddressTypeIPv4Address, TxtNetAddressTypeIPv4Service, TxtNetAddressTypeIPv4Network, TxtNetAddressTypeIPv6Address, TxtNetAddressTypeIPv6AddressNoScope, TxtNetAddressTypeIPv6Service, TxtNetAddressTypeIPv6ServiceNoScope, TxtNetAddressTypeIPv6Network, TxtNetAddressTypeDNSName, TxtNetAddressTypeDNSService, TxtNetAddressTypeIPAddress, TxtNetAddressTypeIPAddressNoScope, TxtNetAddressTypeIPService, TxtNetAddressTypeIPServiceNoScope, TxtNetAddressTypeIPNetwork, TxtNetAddressTypeAnyAddress, TxtNetAddressTypeAnyAddressNoScope, TxtNetAddressTypeAnyService, TxtNetAddressTypeAnyServiceNoScope
  7. #End If
  8. Public Enum TxtCharacterCasingConstants
  9.     TxtCharacterCasingNormal = 0
  10.     TxtCharacterCasingUpper = 1
  11.     TxtCharacterCasingLower = 2
  12. End Enum
  13. Private Const TTI_NONE As Long = 0
  14. Private Const TTI_INFO As Long = 1
  15. Private Const TTI_WARNING As Long = 2
  16. Private Const TTI_ERROR As Long = 3
  17. Public Enum TxtIconConstants
  18.     TxtIconNone = TTI_NONE
  19.     TxtIconInfo = TTI_INFO
  20.     TxtIconWarning = TTI_WARNING
  21.     TxtIconError = TTI_ERROR
  22. End Enum
  23. Private Const NET_ADDRESS_FORMAT_UNSPECIFIED As Long = 0
  24. Private Const NET_ADDRESS_DNS_NAME As Long = 1
  25. Private Const NET_ADDRESS_IPV4 As Long = 2
  26. Private Const NET_ADDRESS_IPV6 As Long = 3
  27. Public Enum TxtNetAddressFormatConstants
  28.     TxtNetAddressFormatNone = NET_ADDRESS_FORMAT_UNSPECIFIED
  29.     TxtNetAddressFormatDNSName = NET_ADDRESS_DNS_NAME
  30.     TxtNetAddressFormatIPv4 = NET_ADDRESS_IPV4
  31.     TxtNetAddressFormatIPv6 = NET_ADDRESS_IPV6
  32. End Enum
  33. Public Enum TxtNetAddressTypeConstants
  34.     TxtNetAddressTypeNone = 0
  35.     TxtNetAddressTypeIPv4Address = 1
  36.     TxtNetAddressTypeIPv4Service = 2
  37.     TxtNetAddressTypeIPv4Network = 3
  38.     TxtNetAddressTypeIPv6Address = 4
  39.     TxtNetAddressTypeIPv6AddressNoScope = 5
  40.     TxtNetAddressTypeIPv6Service = 6
  41.     TxtNetAddressTypeIPv6ServiceNoScope = 7
  42.     TxtNetAddressTypeIPv6Network = 8
  43.     TxtNetAddressTypeDNSName = 9
  44.     TxtNetAddressTypeDNSService = 10
  45.     TxtNetAddressTypeIPAddress = 11
  46.     TxtNetAddressTypeIPAddressNoScope = 12
  47.     TxtNetAddressTypeIPService = 13
  48.     TxtNetAddressTypeIPServiceNoScope = 14
  49.     TxtNetAddressTypeIPNetwork = 15
  50.     TxtNetAddressTypeAnyAddress = 16
  51.     TxtNetAddressTypeAnyAddressNoScope = 17
  52.     TxtNetAddressTypeAnyService = 18
  53.     TxtNetAddressTypeAnyServiceNoScope = 19
  54. End Enum
  55. Private Type RECT
  56.     Left As Long
  57.     Top As Long
  58.     Right As Long
  59.     Bottom As Long
  60. End Type
  61. Private Type SIZEAPI
  62.     cx As Long
  63.     cy As Long
  64. End Type
  65. Private Type POINTAPI
  66.     X As Long
  67.     Y As Long
  68. End Type
  69. Private Type EDITBALLOONTIP
  70.     cbStruct As Long
  71.     pszTitle As Long
  72.     pszText As Long
  73.     iIcon As Long
  74. End Type
  75. Private Type NET_ADDRESS_INFO_UNSPECIFIED
  76.     Format As Integer
  77.     data(0 To (1024 - 1)) As Byte
  78. End Type
  79. Private Const DNS_MAX_NAME_BUFFER_LENGTH As Long = 256
  80. Private Type NET_ADDRESS_INFO_DNS_NAME
  81.     Format As Integer
  82.     Address(0 To ((DNS_MAX_NAME_BUFFER_LENGTH * 2) - 1)) As Byte
  83.     Port(0 To ((6 * 2) - 1)) As Byte
  84. End Type
  85. Private Type NET_ADDRESS_INFO_IPV4
  86.     Format As Integer
  87.     sin_family As Integer
  88.     sin_port As Integer
  89.     sin_addr As Long
  90.     sin_zero(0 To (8 - 1)) As Byte
  91. End Type
  92. Private Type NET_ADDRESS_INFO_IPV6
  93.     Format As Integer
  94.     sin6_family As Integer
  95.     sin6_port As Integer
  96.     sin6_flowinfoLo As Integer
  97.     sin6_flowinfoHi As Integer
  98.     sin6_addr(0 To (8 - 1)) As Integer
  99.     sin6_scope_idLo As Integer
  100.     sin6_scope_idHi As Integer
  101. End Type
  102. Private Type NC_ADDRESS
  103.     pAddrInfo As Long                                                           ' VarPtr(NET_ADDRESS_INFO_*)
  104.     PortNumber As Integer
  105.     PrefixLength As Byte
  106. End Type
  107. Public Event Click()
  108. Public Event DblClick()
  109. Public Event Change()
  110. Public Event MaxText()
  111. Public Event Scroll()
  112. Public Event ContextMenu(ByRef Handled As Boolean, ByVal X As Single, ByVal Y As Single)
  113. Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean)
  114. Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean)
  115. Public Event KeyDown(KeyCode As Integer, Shift As Integer)
  116. Public Event KeyUp(KeyCode As Integer, Shift As Integer)
  117. Public Event KeyPress(KeyChar As Integer)
  118. Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  119. Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  120. Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  121. Public Event MouseEnter()
  122. Public Event MouseLeave()
  123. Public Event OLECompleteDrag(Effect As Long)
  124. Public Event OLEDragDrop(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
  125. Public Event OLEDragOver(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
  126. Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean)
  127. Public Event OLESetData(data As DataObject, DataFormat As Integer)
  128. Public Event OLEStartDrag(data As DataObject, AllowedEffects As Long)
  129. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
  130. Private Declare Function InitNetworkAddressControl Lib "shell32" () As Long
  131. 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
  132. 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
  133. Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
  134. Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
  135. Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
  136. Private Declare Function GetFocus Lib "user32" () As Long
  137. Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
  138. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  139. Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
  140. 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
  141. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  142. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  143. Private Declare Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
  144. Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
  145. Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
  146. Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
  147. Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorW" (ByVal hInstance As Long, ByVal lpCursorName As Any) As Long
  148. Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
  149. Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As Long
  150. Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
  151. Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
  152. Private Declare Function GetScrollPos Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long) As Long
  153. 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
  154. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  155. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  156. Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
  157. Private Declare Function CreateCaret Lib "user32" (ByVal hwnd As Long, ByVal hBitmap As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  158. Private Declare Function SetCaretPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
  159. Private Declare Function ShowCaret Lib "user32" (ByVal hwnd As Long) As Long
  160. Private Declare Function DestroyCaret Lib "user32" () As Long
  161. Private Declare Function DragDetect Lib "user32" (ByVal hwnd As Long, ByVal PX As Integer, ByVal PY As Integer) As Long
  162. Private Const ICC_STANDARD_CLASSES As Long = &H4000
  163. Private Const RDW_UPDATENOW As Long = &H100, RDW_INVALIDATE As Long = &H1, RDW_ERASE As Long = &H4, RDW_ALLCHILDREN As Long = &H80
  164. Private Const GWL_STYLE As Long = (-16)
  165. Private Const CF_UNICODETEXT As Long = 13
  166. Private Const WS_VISIBLE As Long = &H10000000
  167. Private Const WS_CHILD As Long = &H40000000
  168. Private Const WS_EX_RTLREADING As Long = &H2000, WS_EX_LEFTSCROLLBAR As Long = &H4000
  169. Private Const WS_HSCROLL As Long = &H100000
  170. Private Const WS_VSCROLL As Long = &H200000
  171. Private Const SB_LINELEFT As Long = 0, SB_LINERIGHT As Long = 1
  172. Private Const SB_LINEUP As Long = 0, SB_LINEDOWN As Long = 1
  173. Private Const SB_THUMBPOSITION = 4, SB_THUMBTRACK As Long = 5
  174. Private Const SB_HORZ As Long = 0, SB_VERT As Long = 1
  175. 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
  176. Private Const SW_HIDE As Long = &H0
  177. Private Const WM_SETFOCUS As Long = &H7
  178. Private Const WM_KILLFOCUS As Long = &H8
  179. Private Const WM_COMMAND As Long = &H111
  180. Private Const WM_KEYDOWN As Long = &H100
  181. Private Const WM_KEYUP As Long = &H101
  182. Private Const WM_CHAR As Long = &H102
  183. Private Const WM_SYSKEYDOWN As Long = &H104
  184. Private Const WM_SYSKEYUP As Long = &H105
  185. Private Const WM_UNICHAR As Long = &H109, UNICODE_NOCHAR As Long = &HFFFF&
  186. Private Const WM_INPUTLANGCHANGE As Long = &H51
  187. Private Const WM_IME_SETCONTEXT As Long = &H281
  188. Private Const WM_IME_CHAR As Long = &H286
  189. Private Const WM_LBUTTONDOWN As Long = &H201
  190. Private Const WM_LBUTTONUP As Long = &H202
  191. Private Const WM_MBUTTONDOWN As Long = &H207
  192. Private Const WM_MBUTTONUP As Long = &H208
  193. Private Const WM_RBUTTONDOWN As Long = &H204
  194. Private Const WM_RBUTTONUP As Long = &H205
  195. Private Const WM_LBUTTONDBLCLK As Long = &H203
  196. Private Const WM_MBUTTONDBLCLK As Long = &H209
  197. Private Const WM_RBUTTONDBLCLK As Long = &H206
  198. Private Const WM_MOUSEMOVE As Long = &H200
  199. Private Const WM_MOUSELEAVE As Long = &H2A3
  200. Private Const WM_HSCROLL As Long = &H114
  201. Private Const WM_VSCROLL As Long = &H115
  202. Private Const WM_CONTEXTMENU As Long = &H7B
  203. Private Const WM_SETFONT As Long = &H30
  204. Private Const WM_SETCURSOR As Long = &H20, HTCLIENT As Long = 1
  205. Private Const WM_GETTEXTLENGTH As Long = &HE
  206. Private Const WM_GETTEXT As Long = &HD
  207. Private Const WM_SETTEXT As Long = &HC
  208. Private Const WM_COPY As Long = &H301
  209. Private Const WM_CUT As Long = &H300
  210. Private Const WM_PASTE As Long = &H302
  211. Private Const WM_CLEAR As Long = &H303
  212. Private Const WM_USER As Long = &H400
  213. Private Const NCM_GETADDRESS As Long = (WM_USER + 1)
  214. Private Const NCM_SETALLOWTYPE As Long = (WM_USER + 2)
  215. Private Const NCM_GETALLOWTYPE As Long = (WM_USER + 3)
  216. Private Const NCM_DISPLAYERRORTIP As Long = (WM_USER + 4)
  217. Private Const NET_STRING_IPV4_ADDRESS As Long = &H1
  218. Private Const NET_STRING_IPV4_SERVICE As Long = &H2
  219. Private Const NET_STRING_IPV4_NETWORK As Long = &H4
  220. Private Const NET_STRING_IPV6_ADDRESS As Long = &H8
  221. Private Const NET_STRING_IPV6_ADDRESS_NO_SCOPE As Long = &H10
  222. Private Const NET_STRING_IPV6_SERVICE As Long = &H20
  223. Private Const NET_STRING_IPV6_SERVICE_NO_SCOPE As Long = &H40
  224. Private Const NET_STRING_IPV6_NETWORK As Long = &H80
  225. Private Const NET_STRING_NAMED_ADDRESS As Long = &H100
  226. Private Const NET_STRING_NAMED_SERVICE As Long = &H200
  227. Private Const NET_STRING_IP_ADDRESS As Long = (NET_STRING_IPV4_ADDRESS Or NET_STRING_IPV6_ADDRESS)
  228. Private Const NET_STRING_IP_ADDRESS_NO_SCOPE As Long = (NET_STRING_IPV4_ADDRESS Or NET_STRING_IPV6_ADDRESS_NO_SCOPE)
  229. Private Const NET_STRING_IP_SERVICE As Long = (NET_STRING_IPV4_SERVICE Or NET_STRING_IPV6_SERVICE)
  230. Private Const NET_STRING_IP_SERVICE_NO_SCOPE As Long = (NET_STRING_IPV4_SERVICE Or NET_STRING_IPV6_SERVICE_NO_SCOPE)
  231. Private Const NET_STRING_IP_NETWORK As Long = (NET_STRING_IPV4_NETWORK Or NET_STRING_IPV6_NETWORK)
  232. Private Const NET_STRING_ANY_ADDRESS As Long = (NET_STRING_NAMED_ADDRESS Or NET_STRING_IP_ADDRESS)
  233. Private Const NET_STRING_ANY_ADDRESS_NO_SCOPE As Long = (NET_STRING_NAMED_ADDRESS Or NET_STRING_IP_ADDRESS_NO_SCOPE)
  234. Private Const NET_STRING_ANY_SERVICE As Long = (NET_STRING_NAMED_SERVICE Or NET_STRING_IP_SERVICE)
  235. Private Const NET_STRING_ANY_SERVICE_NO_SCOPE As Long = (NET_STRING_NAMED_SERVICE Or NET_STRING_IP_SERVICE_NO_SCOPE)
  236. Private Const EM_SETREADONLY As Long = &HCF, ES_READONLY As Long = &H800
  237. Private Const EM_GETSEL As Long = &HB0
  238. Private Const EM_SETSEL As Long = &HB1
  239. Private Const EM_SCROLL As Long = &HB5
  240. Private Const EM_LINESCROLL As Long = &HB6
  241. Private Const EM_SCROLLCARET As Long = &HB7
  242. Private Const EM_REPLACESEL As Long = &HC2
  243. Private Const EM_GETPASSWORDCHAR As Long = &HD2
  244. Private Const EM_SETPASSWORDCHAR As Long = &HCC
  245. Private Const EM_GETLIMITTEXT As Long = &HD5
  246. Private Const EM_LIMITTEXT As Long = &HC5
  247. Private Const EM_SETLIMITTEXT As Long = EM_LIMITTEXT
  248. Private Const EM_GETMODIFY As Long = &HB8
  249. Private Const EM_SETMODIFY As Long = &HB9
  250. Private Const EM_LINEINDEX As Long = &HBB
  251. Private Const EM_GETTHUMB As Long = &HBE
  252. Private Const EM_LINELENGTH As Long = &HC1
  253. Private Const EM_GETLINE As Long = &HC4
  254. Private Const EM_UNDO As Long = &HC7
  255. Private Const EM_CANUNDO As Long = &HC6
  256. Private Const EM_LINEFROMCHAR As Long = &HC9
  257. Private Const EM_EMPTYUNDOBUFFER As Long = &HCD
  258. Private Const EM_GETFIRSTVISIBLELINE As Long = &HCE
  259. Private Const EM_GETLINECOUNT As Long = &HBA
  260. Private Const EM_GETMARGINS As Long = &HD4
  261. Private Const EM_SETMARGINS As Long = &HD3
  262. Private Const EM_POSFROMCHAR As Long = &HD6
  263. Private Const EM_CHARFROMPOS As Long = &HD7
  264. Private Const ECM_FIRST As Long = &H1500
  265. Private Const EM_SETCUEBANNER As Long = (ECM_FIRST + 1)
  266. Private Const EM_GETCUEBANNER As Long = (ECM_FIRST + 2)
  267. Private Const EM_SHOWBALLOONTIP As Long = (ECM_FIRST + 3)
  268. Private Const EM_HIDEBALLOONTIP As Long = (ECM_FIRST + 4)
  269. Private Const EN_UPDATE As Long = &H400
  270. Private Const EN_CHANGE As Long = &H300
  271. Private Const EN_MAXTEXT As Long = &H501
  272. Private Const EN_HSCROLL As Long = &H601
  273. Private Const EN_VSCROLL As Long = &H602
  274. Private Const ES_AUTOHSCROLL As Long = &H80
  275. Private Const ES_AUTOVSCROLL As Long = &H40
  276. Private Const ES_NUMBER As Long = &H2000
  277. Private Const ES_NOHIDESEL As Long = &H100
  278. Private Const ES_LEFT As Long = &H0
  279. Private Const ES_CENTER As Long = &H1
  280. Private Const ES_RIGHT As Long = &H2
  281. Private Const ES_MULTILINE As Long = &H4
  282. Private Const ES_UPPERCASE As Long = &H8
  283. Private Const ES_LOWERCASE As Long = &H10
  284. Private Const ES_PASSWORD As Long = &H20
  285. Private Const ES_WANTRETURN As Long = &H1000
  286. Private Const EC_LEFTMARGIN As Long = &H1
  287. Private Const EC_RIGHTMARGIN As Long = &H2
  288. Private Const EC_USEFONTINFO As Long = &HFFFF&
  289. Implements ISubclass
  290. Implements OLEGuids.IObjectSafety
  291. Implements OLEGuids.IOleInPlaceActiveObjectVB
  292. Implements OLEGuids.IOleControlVB
  293. Implements OLEGuids.IPerPropertyBrowsingVB
  294. Private TextBoxHandle As Long
  295. Private TextBoxFontHandle As Long
  296. Private TextBoxIMCHandle As Long
  297. Private TextBoxCharCodeCache As Long
  298. Private TextBoxAutoDragInSel As Boolean, TextBoxAutoDragIsActive As Boolean
  299. Private TextBoxIsClick As Boolean
  300. Private TextBoxMouseOver As Boolean
  301. Private TextBoxDesignMode As Boolean, TextBoxTopDesignMode As Boolean
  302. Private TextBoxChangeFrozen As Boolean
  303. Private TextBoxNetAddressFormat As TxtNetAddressFormatConstants
  304. Private TextBoxNetAddressString As String
  305. Private TextBoxNetAddressPortNumber As Integer
  306. Private TextBoxNetAddressPrefixLength As Byte
  307. Private DispIDMousePointer As Long
  308. Private WithEvents PropFont As StdFont
  309. Private PropVisualStyles As Boolean
  310. Private PropOLEDragMode As VBRUN.OLEDragConstants
  311. Private PropOLEDragDropScroll As Boolean
  312. Private PropOLEDropMode As VBRUN.OLEDropConstants
  313. Private PropMousePointer As Integer, PropMouseIcon As IPictureDisp
  314. Private PropMouseTrack As Boolean
  315. Private PropRightToLeft As Boolean
  316. Private PropRightToLeftMode As CCRightToLeftModeConstants
  317. Private PropBorderStyle As CCBorderStyleConstants
  318. Private PropText As String
  319. Private PropAlignment As VBRUN.AlignmentConstants
  320. Private PropAllowOnlyNumbers As Boolean
  321. Private PropLocked As Boolean
  322. Private PropHideSelection As Boolean
  323. Private PropPasswordChar As Integer
  324. Private PropUseSystemPasswordChar As Boolean
  325. Private PropMultiLine As Boolean
  326. Private PropMaxLength As Long
  327. Private PropScrollBars As VBRUN.ScrollBarConstants
  328. Private PropCueBanner As String
  329. Private PropCharacterCasing As TxtCharacterCasingConstants
  330. Private PropWantReturn As Boolean
  331. Private PropIMEMode As CCIMEModeConstants
  332. Private PropNetAddressValidator As Boolean
  333. Private PropNetAddressType As TxtNetAddressTypeConstants
  334. Private PropAllowOverType As Boolean
  335. Private PropOverTypeMode As Boolean

  336. Private Sub IObjectSafety_GetInterfaceSafetyOptions(ByRef riid As OLEGuids.OLECLSID, ByRef pdwSupportedOptions As Long, ByRef pdwEnabledOptions As Long)
  337.     Const INTERFACESAFE_FOR_UNTRUSTED_CALLER As Long = &H1, INTERFACESAFE_FOR_UNTRUSTED_DATA As Long = &H2
  338.     pdwSupportedOptions = INTERFACESAFE_FOR_UNTRUSTED_CALLER Or INTERFACESAFE_FOR_UNTRUSTED_DATA
  339.     pdwEnabledOptions = INTERFACESAFE_FOR_UNTRUSTED_CALLER Or INTERFACESAFE_FOR_UNTRUSTED_DATA
  340. End Sub

  341. Private Sub IObjectSafety_SetInterfaceSafetyOptions(ByRef riid As OLEGuids.OLECLSID, ByVal dwOptionsSetMask As Long, ByVal dwEnabledOptions As Long)
  342. End Sub

  343. 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)
  344.     If wMsg = WM_KEYDOWN Or wMsg = WM_KEYUP Then
  345.         Dim KeyCode As Integer, IsInputKey As Boolean
  346.         KeyCode = wParam And &HFF&
  347.         If wMsg = WM_KEYDOWN Then
  348.             RaiseEvent PreviewKeyDown(KeyCode, IsInputKey)
  349.         ElseIf wMsg = WM_KEYUP Then
  350.             RaiseEvent PreviewKeyUp(KeyCode, IsInputKey)
  351.         End If
  352.         Select Case KeyCode
  353.         Case vbKeyUp, vbKeyDown, vbKeyLeft, vbKeyRight, vbKeyPageDown, vbKeyPageUp, vbKeyHome, vbKeyEnd
  354.             If TextBoxHandle <> 0 Then
  355.                 SendMessage TextBoxHandle, wMsg, wParam, ByVal lParam
  356.                 Handled = True
  357.             End If
  358.         Case vbKeyTab, vbKeyReturn, vbKeyEscape
  359.             If IsInputKey = True Then
  360.                 If TextBoxHandle <> 0 Then
  361.                     SendMessage TextBoxHandle, wMsg, wParam, ByVal lParam
  362.                     Handled = True
  363.                 End If
  364.             End If
  365.         End Select
  366.     End If
  367. End Sub

  368. Private Sub IOleControlVB_GetControlInfo(ByRef Handled As Boolean, ByRef AccelCount As Integer, ByRef AccelTable As Long, ByRef Flags As Long)
  369.     If PropWantReturn = True And PropMultiLine = True Then
  370.         Flags = CTRLINFO_EATS_RETURN
  371.         Handled = True
  372.     End If
  373. End Sub

  374. Private Sub IOleControlVB_OnMnemonic(ByRef Handled As Boolean, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal Shift As Long)
  375. End Sub

  376. Private Sub IPerPropertyBrowsingVB_GetDisplayString(ByRef Handled As Boolean, ByVal DispID As Long, ByRef DisplayName As String)
  377.     If DispID = DispIDMousePointer Then
  378.         Call ComCtlsIPPBSetDisplayStringMousePointer(PropMousePointer, DisplayName)
  379.         Handled = True
  380.     End If
  381. End Sub

  382. Private Sub IPerPropertyBrowsingVB_GetPredefinedStrings(ByRef Handled As Boolean, ByVal DispID As Long, ByRef StringsOut() As String, ByRef CookiesOut() As Long)
  383.     If DispID = DispIDMousePointer Then
  384.         Call ComCtlsIPPBSetPredefinedStringsMousePointer(StringsOut(), CookiesOut())
  385.         Handled = True
  386.     End If
  387. End Sub

  388. Private Sub IPerPropertyBrowsingVB_GetPredefinedValue(ByRef Handled As Boolean, ByVal DispID As Long, ByVal Cookie As Long, ByRef Value As Variant)
  389.     If DispID = DispIDMousePointer Then
  390.         Value = Cookie
  391.         Handled = True
  392.     End If
  393. End Sub

  394. Private Sub UserControl_Initialize()
  395.     Call ComCtlsLoadShellMod
  396.     Call ComCtlsInitCC(ICC_STANDARD_CLASSES)
  397.     Call SetVTableSubclass(Me, VTableInterfaceInPlaceActiveObject)
  398.     Call SetVTableSubclass(Me, VTableInterfaceControl)
  399.     Call SetVTableSubclass(Me, VTableInterfacePerPropertyBrowsing)
  400. End Sub

  401. Private Sub UserControl_InitProperties()
  402.     If DispIDMousePointer = 0 Then DispIDMousePointer = GetDispID(Me, "MousePointer")
  403.     On Error Resume Next
  404.     TextBoxDesignMode = Not Ambient.UserMode
  405.     TextBoxTopDesignMode = Not GetTopUserControl(Me).Ambient.UserMode
  406.     On Error GoTo 0
  407.     Set PropFont = Ambient.Font
  408.     PropVisualStyles = True
  409.     PropOLEDragMode = vbOLEDragManual
  410.     PropOLEDragDropScroll = True
  411.     PropOLEDropMode = vbOLEDropNone
  412.     PropMousePointer = 0: Set PropMouseIcon = Nothing
  413.     PropMouseTrack = False
  414.     PropRightToLeft = Ambient.RightToLeft
  415.     PropRightToLeftMode = CCRightToLeftModeVBAME
  416.     If PropRightToLeft = True Then Me.RightToLeft = True
  417.     PropBorderStyle = CCBorderStyleSunken
  418.     PropText = Ambient.DisplayName
  419.     If PropRightToLeft = False Then PropAlignment = vbLeftJustify Else PropAlignment = vbRightJustify
  420.     PropAllowOnlyNumbers = False
  421.     PropLocked = False
  422.     PropHideSelection = True
  423.     PropPasswordChar = 0
  424.     PropUseSystemPasswordChar = False
  425.     PropMultiLine = False
  426.     PropMaxLength = 0
  427.     PropScrollBars = vbSBNone
  428.     PropCueBanner = vbNullString
  429.     PropCharacterCasing = TxtCharacterCasingNormal
  430.     PropWantReturn = False
  431.     PropIMEMode = CCIMEModeNoControl
  432.     PropNetAddressValidator = False
  433.     PropNetAddressType = TxtNetAddressTypeNone
  434.     PropAllowOverType = False
  435.     PropOverTypeMode = False
  436.     Call CreateTextBox
  437. End Sub

  438. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  439.     If DispIDMousePointer = 0 Then DispIDMousePointer = GetDispID(Me, "MousePointer")
  440.     On Error Resume Next
  441.     TextBoxDesignMode = Not Ambient.UserMode
  442.     TextBoxTopDesignMode = Not GetTopUserControl(Me).Ambient.UserMode
  443.     On Error GoTo 0
  444.     With PropBag
  445.         Set PropFont = .ReadProperty("Font", Nothing)
  446.         PropVisualStyles = .ReadProperty("VisualStyles", True)
  447.         Me.BackColor = .ReadProperty("BackColor", vbWindowBackground)
  448.         Me.ForeColor = .ReadProperty("ForeColor", vbWindowText)
  449.         Me.Enabled = .ReadProperty("Enabled", True)
  450.         PropOLEDragMode = .ReadProperty("OLEDragMode", vbOLEDragManual)
  451.         PropOLEDragDropScroll = .ReadProperty("OLEDragDropScroll", True)
  452.         Me.OLEDropMode = .ReadProperty("OLEDropMode", vbOLEDropNone)
  453.         PropMousePointer = .ReadProperty("MousePointer", 0)
  454.         Set PropMouseIcon = .ReadProperty("MouseIcon", Nothing)
  455.         PropMouseTrack = .ReadProperty("MouseTrack", False)
  456.         PropRightToLeft = .ReadProperty("RightToLeft", False)
  457.         PropRightToLeftMode = .ReadProperty("RightToLeftMode", CCRightToLeftModeVBAME)
  458.         If PropRightToLeft = True Then Me.RightToLeft = True
  459.         PropBorderStyle = .ReadProperty("BorderStyle", CCBorderStyleSunken)
  460.         PropText = VarToStr(.ReadProperty("Text", vbNullString))
  461.         PropAlignment = .ReadProperty("Alignment", vbLeftJustify)
  462.         PropAllowOnlyNumbers = .ReadProperty("AllowOnlyNumbers", False)
  463.         PropLocked = .ReadProperty("Locked", False)
  464.         PropHideSelection = .ReadProperty("HideSelection", True)
  465.         PropPasswordChar = .ReadProperty("PasswordChar", 0)
  466.         PropUseSystemPasswordChar = .ReadProperty("UseSystemPasswordChar", False)
  467.         PropMultiLine = .ReadProperty("MultiLine", False)
  468.         PropMaxLength = .ReadProperty("MaxLength", 0)
  469.         PropScrollBars = .ReadProperty("ScrollBars", vbSBNone)
  470.         PropCueBanner = VarToStr(.ReadProperty("CueBanner", vbNullString))
  471.         PropCharacterCasing = .ReadProperty("CharacterCasing", TxtCharacterCasingNormal)
  472.         PropWantReturn = .ReadProperty("WantReturn", False)
  473.         PropIMEMode = .ReadProperty("IMEMode", CCIMEModeNoControl)
  474.         PropNetAddressValidator = .ReadProperty("NetAddressValidator", False)
  475.         PropNetAddressType = .ReadProperty("NetAddressType", TxtNetAddressTypeNone)
  476.         PropAllowOverType = .ReadProperty("AllowOverType", False)
  477.         PropOverTypeMode = .ReadProperty("OverTypeMode", False)
  478.     End With
  479.     Call CreateTextBox
  480. End Sub

  481. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  482.     With PropBag
  483.         .WriteProperty "Font", IIf(OLEFontIsEqual(PropFont, Ambient.Font) = False, PropFont, Nothing), Nothing
  484.         .WriteProperty "VisualStyles", PropVisualStyles, True
  485.         .WriteProperty "BackColor", Me.BackColor, vbWindowBackground
  486.         .WriteProperty "ForeColor", Me.ForeColor, vbWindowText
  487.         .WriteProperty "Enabled", Me.Enabled, True
  488.         .WriteProperty "OLEDragMode", PropOLEDragMode, vbOLEDragManual
  489.         .WriteProperty "OLEDragDropScroll", PropOLEDragDropScroll, True
  490.         .WriteProperty "OLEDropMode", PropOLEDropMode, vbOLEDropNone
  491.         .WriteProperty "MousePointer", PropMousePointer, 0
  492.         .WriteProperty "MouseIcon", PropMouseIcon, Nothing
  493.         .WriteProperty "MouseTrack", PropMouseTrack, False
  494.         .WriteProperty "RightToLeft", PropRightToLeft, False
  495.         .WriteProperty "RightToLeftMode", PropRightToLeftMode, CCRightToLeftModeVBAME
  496.         .WriteProperty "BorderStyle", PropBorderStyle, CCBorderStyleSunken
  497.         .WriteProperty "Text", StrToVar(PropText), vbNullString
  498.         .WriteProperty "Alignment", PropAlignment, vbLeftJustify
  499.         .WriteProperty "AllowOnlyNumbers", PropAllowOnlyNumbers, False
  500.         .WriteProperty "Locked", PropLocked, False
  501.         .WriteProperty "HideSelection", PropHideSelection, True
  502.         .WriteProperty "PasswordChar", PropPasswordChar, 0
  503.         .WriteProperty "UseSystemPasswordChar", PropUseSystemPasswordChar, False
  504.         .WriteProperty "MultiLine", PropMultiLine, False
  505.         .WriteProperty "MaxLength", PropMaxLength, 0
  506.         .WriteProperty "ScrollBars", PropScrollBars, vbSBNone
  507.         .WriteProperty "CueBanner", StrToVar(PropCueBanner), vbNullString
  508.         .WriteProperty "CharacterCasing", PropCharacterCasing, TxtCharacterCasingNormal
  509.         .WriteProperty "WantReturn", PropWantReturn, False
  510.         .WriteProperty "IMEMode", PropIMEMode, CCIMEModeNoControl
  511.         .WriteProperty "NetAddressValidator", PropNetAddressValidator, False
  512.         .WriteProperty "NetAddressType", PropNetAddressType, TxtNetAddressTypeNone
  513.         .WriteProperty "AllowOverType", PropAllowOverType, False
  514.         .WriteProperty "OverTypeMode", PropOverTypeMode, False
  515.     End With
  516. End Sub

  517. Private Sub UserControl_OLECompleteDrag(Effect As Long)
  518.     If PropOLEDragMode = vbOLEDragAutomatic And TextBoxAutoDragIsActive = True And Effect = vbDropEffectMove Then
  519.         If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, WM_CLEAR, 0, ByVal 0&
  520.     End If
  521.     RaiseEvent OLECompleteDrag(Effect)
  522.     TextBoxAutoDragIsActive = False
  523. End Sub

  524. Private Sub UserControl_OLEDragDrop(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
  525.     RaiseEvent OLEDragDrop(data, Effect, Button, Shift, UserControl.ScaleX(X, vbPixels, vbContainerPosition), UserControl.ScaleY(Y, vbPixels, vbContainerPosition))
  526.     If PropOLEDropMode = vbOLEDropAutomatic And TextBoxHandle <> 0 Then
  527.         If Not Effect = vbDropEffectNone Then
  528.             Me.Refresh
  529.             Dim Text As String
  530.             If data.GetFormat(CF_UNICODETEXT) = True Then
  531.                 Text = data.GetData(CF_UNICODETEXT)
  532.                 Text = Left$(Text, InStr(Text, vbNullChar) - 1)
  533.             ElseIf data.GetFormat(vbCFText) = True Then
  534.                 Text = data.GetData(vbCFText)
  535.             End If
  536.             If Not Text = vbNullString Then
  537.                 Dim CharPos As Long
  538.                 CharPos = CIntToUInt(LoWord(SendMessage(TextBoxHandle, EM_CHARFROMPOS, 0, ByVal MakeDWord(X, Y))))
  539.                 If TextBoxAutoDragIsActive = True Then
  540.                     TextBoxAutoDragIsActive = False
  541.                     Dim SelStart As Long, SelEnd As Long
  542.                     SendMessage TextBoxHandle, EM_GETSEL, VarPtr(SelStart), ByVal VarPtr(SelEnd)
  543.                     If CharPos >= SelStart And CharPos <= SelEnd Then
  544.                         Effect = vbDropEffectNone
  545.                         Exit Sub
  546.                     End If
  547.                     If SelStart < CharPos Then CharPos = CharPos - (SelEnd - SelStart)
  548.                     If Effect = vbDropEffectMove Then SendMessage TextBoxHandle, WM_CLEAR, 0, ByVal 0&
  549.                 Else
  550.                     If GetFocus() <> TextBoxHandle Then SetFocusAPI UserControl.hwnd
  551.                 End If
  552.                 SendMessage TextBoxHandle, EM_SETSEL, CharPos, ByVal CharPos
  553.                 SendMessage TextBoxHandle, EM_REPLACESEL, 1, ByVal StrPtr(Text)
  554.                 SendMessage TextBoxHandle, EM_SETSEL, CharPos, ByVal (CharPos + Len(Text))
  555.             End If
  556.         End If
  557.     End If
  558. End Sub

  559. 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)
  560.     RaiseEvent OLEDragOver(data, Effect, Button, Shift, UserControl.ScaleX(X, vbPixels, vbContainerPosition), UserControl.ScaleY(Y, vbPixels, vbContainerPosition), State)
  561.     If TextBoxHandle <> 0 Then
  562.         If State = vbOver And Not Effect = vbDropEffectNone Then
  563.             If PropOLEDragDropScroll = True Then
  564.                 Dim RC As RECT
  565.                 GetWindowRect TextBoxHandle, RC
  566.                 Dim dwStyle As Long
  567.                 dwStyle = GetWindowLong(TextBoxHandle, GWL_STYLE)
  568.                 If (dwStyle And WS_HSCROLL) = WS_HSCROLL Then
  569.                     If Abs(X) < (16 * PixelsPerDIP_X()) Then
  570.                         SendMessage TextBoxHandle, WM_HSCROLL, SB_LINELEFT, ByVal 0&
  571.                     ElseIf Abs(X - (RC.Right - RC.Left)) < (16 * PixelsPerDIP_X()) Then
  572.                         SendMessage TextBoxHandle, WM_HSCROLL, SB_LINERIGHT, ByVal 0&
  573.                     End If
  574.                 End If
  575.                 If (dwStyle And WS_VSCROLL) = WS_VSCROLL Then
  576.                     If Abs(Y) < (16 * PixelsPerDIP_Y()) Then
  577.                         SendMessage TextBoxHandle, WM_VSCROLL, SB_LINEUP, ByVal 0&
  578.                     ElseIf Abs(Y - (RC.Bottom - RC.Top)) < (16 * PixelsPerDIP_Y()) Then
  579.                         SendMessage TextBoxHandle, WM_VSCROLL, SB_LINEDOWN, ByVal 0&
  580.                     End If
  581.                 End If
  582.             End If
  583.         End If
  584.         If PropOLEDropMode = vbOLEDropAutomatic Then
  585.             If State = vbOver And Not Effect = vbDropEffectNone Then
  586.                 Dim CharPos As Long, CaretPos As Long
  587.                 CharPos = CIntToUInt(LoWord(SendMessage(TextBoxHandle, EM_CHARFROMPOS, 0, ByVal MakeDWord(X, Y))))
  588.                 CaretPos = SendMessage(TextBoxHandle, EM_POSFROMCHAR, CharPos, ByVal 0&)
  589.                 If CaretPos > -1 Then
  590.                     Dim hDC As Long, Size As SIZEAPI
  591.                     hDC = GetDC(TextBoxHandle)
  592.                     SelectObject hDC, TextBoxFontHandle
  593.                     GetTextExtentPoint32 hDC, StrPtr("|"), 1, Size
  594.                     ReleaseDC TextBoxHandle, hDC
  595.                     CreateCaret TextBoxHandle, 0, 0, Size.cy
  596.                     SetCaretPos LoWord(CaretPos), HiWord(CaretPos)
  597.                     ShowCaret TextBoxHandle
  598.                 Else
  599.                     If GetFocus() <> TextBoxHandle Then
  600.                         DestroyCaret
  601.                     Else
  602.                         Me.Refresh
  603.                     End If
  604.                 End If
  605.             ElseIf State = vbLeave Then
  606.                 If GetFocus() <> TextBoxHandle Then
  607.                     DestroyCaret
  608.                 Else
  609.                     Me.Refresh
  610.                 End If
  611.             End If
  612.         End If
  613.     End If
  614. End Sub

  615. Private Sub UserControl_OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean)
  616.     RaiseEvent OLEGiveFeedback(Effect, DefaultCursors)
  617. End Sub

  618. Private Sub UserControl_OLESetData(data As DataObject, DataFormat As Integer)
  619.     RaiseEvent OLESetData(data, DataFormat)
  620. End Sub

  621. Private Sub UserControl_OLEStartDrag(data As DataObject, AllowedEffects As Long)
  622.     If PropOLEDragMode = vbOLEDragAutomatic Then
  623.         Dim Text As String
  624.         Text = Me.SelText
  625.         data.SetData StrToVar(Text & vbNullChar), CF_UNICODETEXT
  626.         data.SetData StrToVar(Text), vbCFText
  627.         AllowedEffects = vbDropEffectMove
  628.         TextBoxAutoDragIsActive = True
  629.     End If
  630.     RaiseEvent OLEStartDrag(data, AllowedEffects)
  631.     If AllowedEffects = vbDropEffectNone Then TextBoxAutoDragIsActive = False
  632. End Sub

  633. Public Sub OLEDrag()
  634.     UserControl.OLEDrag
  635. End Sub

  636. Private Sub UserControl_Resize()
  637.     Static InProc As Boolean
  638.     If InProc = True Then Exit Sub
  639.     InProc = True
  640.     With UserControl
  641.         If DPICorrectionFactor() <> 1 Then Call SyncObjectRectsToContainer(Me)
  642.         If TextBoxHandle <> 0 Then MoveWindow TextBoxHandle, 0, 0, .ScaleWidth, .ScaleHeight, 1
  643.     End With
  644.     InProc = False
  645. End Sub

  646. Private Sub UserControl_Terminate()
  647.     Call RemoveVTableSubclass(Me, VTableInterfaceInPlaceActiveObject)
  648.     Call RemoveVTableSubclass(Me, VTableInterfaceControl)
  649.     Call RemoveVTableSubclass(Me, VTableInterfacePerPropertyBrowsing)
  650.     Call DestroyTextBox
  651.     Call ComCtlsReleaseShellMod
  652. End Sub

  653. Public Property Get Name() As String
  654. Name = Ambient.DisplayName
  655. End Property

  656. Public Property Get Tag() As String
  657.     Tag = Extender.Tag
  658. End Property

  659. Public Property Let Tag(ByVal Value As String)
  660.     Extender.Tag = Value
  661. End Property

  662. Public Property Get Parent() As Object
  663. Set Parent = UserControl.Parent
  664. End Property

  665. Public Property Get Container() As Object
  666.     Set Container = Extender.Container
  667. End Property

  668. Public Property Set Container(ByVal Value As Object)
  669.     Set Extender.Container = Value
  670. End Property

  671. Public Property Get Left() As Single
  672.     Left = Extender.Left
  673. End Property

  674. Public Property Let Left(ByVal Value As Single)
  675.     Extender.Left = Value
  676. End Property

  677. Public Property Get Top() As Single
  678.     Top = Extender.Top
  679. End Property

  680. Public Property Let Top(ByVal Value As Single)
  681.     Extender.Top = Value
  682. End Property

  683. Public Property Get Width() As Single
  684.     Width = Extender.Width
  685. End Property

  686. Public Property Let Width(ByVal Value As Single)
  687.     Extender.Width = Value
  688. End Property

  689. Public Property Get Height() As Single
  690.     Height = Extender.Height
  691. End Property

  692. Public Property Let Height(ByVal Value As Single)
  693.     Extender.Height = Value
  694. End Property

  695. Public Property Get Visible() As Boolean
  696.     Visible = Extender.Visible
  697. End Property

  698. Public Property Let Visible(ByVal Value As Boolean)
  699.     Extender.Visible = Value
  700. End Property

  701. Public Property Get ToolTipText() As String
  702.     ToolTipText = Extender.ToolTipText
  703. End Property

  704. Public Property Let ToolTipText(ByVal Value As String)
  705.     Extender.ToolTipText = Value
  706. End Property

  707. Public Property Get HelpContextID() As Long
  708.     HelpContextID = Extender.HelpContextID
  709. End Property

  710. Public Property Let HelpContextID(ByVal Value As Long)
  711.     Extender.HelpContextID = Value
  712. End Property

  713. Public Property Get WhatsThisHelpID() As Long
  714.     WhatsThisHelpID = Extender.WhatsThisHelpID
  715. End Property

  716. Public Property Let WhatsThisHelpID(ByVal Value As Long)
  717.     Extender.WhatsThisHelpID = Value
  718. End Property

  719. Public Property Get DragIcon() As IPictureDisp
  720.     Set DragIcon = Extender.DragIcon
  721. End Property

  722. Public Property Let DragIcon(ByVal Value As IPictureDisp)
  723.     Extender.DragIcon = Value
  724. End Property

  725. Public Property Set DragIcon(ByVal Value As IPictureDisp)
  726. Set Extender.DragIcon = Value
  727. End Property

  728. Public Property Get DragMode() As Integer
  729.     DragMode = Extender.DragMode
  730. End Property

  731. Public Property Let DragMode(ByVal Value As Integer)
  732.     Extender.DragMode = Value
  733. End Property

  734. Public Sub Drag(Optional ByRef Action As Variant)
  735.     If IsMissing(Action) Then Extender.Drag Else Extender.Drag Action
  736. End Sub

  737. Public Sub SetFocus()
  738.     Extender.SetFocus
  739. End Sub

  740. Public Sub ZOrder(Optional ByRef Position As Variant)
  741.     If IsMissing(Position) Then Extender.ZOrder Else Extender.ZOrder Position
  742. End Sub

  743. Public Property Get hwnd() As Long
  744. hwnd = TextBoxHandle
  745. End Property

  746. Public Property Get hWndUserControl() As Long
  747. hWndUserControl = UserControl.hwnd
  748. End Property

  749. Public Property Get Font() As StdFont
  750.     Set Font = PropFont
  751. End Property

  752. Public Property Let Font(ByVal NewFont As StdFont)
  753.     Set Me.Font = NewFont
  754. End Property

  755. Public Property Set Font(ByVal NewFont As StdFont)
  756. If NewFont Is Nothing Then Set NewFont = Ambient.Font
  757. Dim OldFontHandle As Long
  758. Set PropFont = NewFont
  759. OldFontHandle = TextBoxFontHandle
  760. TextBoxFontHandle = CreateGDIFontFromOLEFont(PropFont)
  761. If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, WM_SETFONT, TextBoxFontHandle, ByVal 1&
  762. If OldFontHandle <> 0 Then DeleteObject OldFontHandle
  763. UserControl.PropertyChanged "Font"
  764. End Property

  765. Private Sub PropFont_FontChanged(ByVal PropertyName As String)
  766.     Dim OldFontHandle As Long
  767.     OldFontHandle = TextBoxFontHandle
  768.     TextBoxFontHandle = CreateGDIFontFromOLEFont(PropFont)
  769.     If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, WM_SETFONT, TextBoxFontHandle, ByVal 1&
  770.     If OldFontHandle <> 0 Then DeleteObject OldFontHandle
  771.     UserControl.PropertyChanged "Font"
  772. End Sub

  773. Public Property Get VisualStyles() As Boolean
  774.     VisualStyles = PropVisualStyles
  775. End Property

  776. Public Property Let VisualStyles(ByVal Value As Boolean)
  777.     PropVisualStyles = Value
  778.     If TextBoxHandle <> 0 And EnabledVisualStyles() = True Then
  779.         If PropVisualStyles = True Then
  780.             ActivateVisualStyles TextBoxHandle
  781.         Else
  782.             RemoveVisualStyles TextBoxHandle
  783.         End If
  784.         Me.Refresh
  785.     End If
  786.     UserControl.PropertyChanged "VisualStyles"
  787. End Property

  788. Public Property Get BackColor() As OLE_COLOR
  789.     BackColor = UserControl.BackColor
  790. End Property

  791. Public Property Let BackColor(ByVal Value As OLE_COLOR)
  792.     UserControl.BackColor = Value
  793.     Me.Refresh
  794.     UserControl.PropertyChanged "BackColor"
  795. End Property

  796. Public Property Get ForeColor() As OLE_COLOR
  797.     ForeColor = UserControl.ForeColor
  798. End Property

  799. Public Property Let ForeColor(ByVal Value As OLE_COLOR)
  800.     UserControl.ForeColor = Value
  801.     Me.Refresh
  802.     UserControl.PropertyChanged "ForeColor"
  803. End Property

  804. Public Property Get Enabled() As Boolean
  805.     Enabled = UserControl.Enabled
  806. End Property

  807. Public Property Let Enabled(ByVal Value As Boolean)
  808.     UserControl.Enabled = Value
  809.     If TextBoxHandle <> 0 Then EnableWindow TextBoxHandle, IIf(Value = True, 1, 0)
  810.     UserControl.PropertyChanged "Enabled"
  811. End Property

  812. Public Property Get OLEDragMode() As VBRUN.OLEDragConstants
  813.     OLEDragMode = PropOLEDragMode
  814. End Property

  815. Public Property Let OLEDragMode(ByVal Value As VBRUN.OLEDragConstants)
  816.     Select Case Value
  817.     Case vbOLEDragManual, vbOLEDragAutomatic
  818.         PropOLEDragMode = Value
  819.     Case Else
  820.         ERR.Raise 380
  821.     End Select
  822.     UserControl.PropertyChanged "OLEDragMode"
  823. End Property

  824. Public Property Get OLEDragDropScroll() As Boolean
  825.     OLEDragDropScroll = PropOLEDragDropScroll
  826. End Property

  827. Public Property Let OLEDragDropScroll(ByVal Value As Boolean)
  828.     PropOLEDragDropScroll = Value
  829.     UserControl.PropertyChanged "OLEDragDropScroll"
  830. End Property

  831. Public Property Get OLEDropMode() As VBRUN.OLEDropConstants
  832.     OLEDropMode = PropOLEDropMode
  833. End Property

  834. Public Property Let OLEDropMode(ByVal Value As VBRUN.OLEDropConstants)
  835.     Select Case Value
  836.     Case vbOLEDropNone, vbOLEDropManual, vbOLEDropAutomatic
  837.         PropOLEDropMode = Value
  838.         UserControl.OLEDropMode = IIf(PropOLEDropMode = vbOLEDropAutomatic, vbOLEDropManual, Value)
  839.     Case Else
  840.         ERR.Raise 380
  841.     End Select
  842.     UserControl.PropertyChanged "OLEDropMode"
  843. End Property

  844. Public Property Get MousePointer() As Integer
  845.     MousePointer = PropMousePointer
  846. End Property

  847. Public Property Let MousePointer(ByVal Value As Integer)
  848.     Select Case Value
  849.     Case 0 To 16, 99
  850.         PropMousePointer = Value
  851.     Case Else
  852.         ERR.Raise 380
  853.     End Select
  854.     UserControl.PropertyChanged "MousePointer"
  855. End Property

  856. Public Property Get MouseIcon() As IPictureDisp
  857.     Set MouseIcon = PropMouseIcon
  858. End Property

  859. Public Property Let MouseIcon(ByVal Value As IPictureDisp)
  860.     Set Me.MouseIcon = Value
  861. End Property

  862. Public Property Set MouseIcon(ByVal Value As IPictureDisp)
  863. If Value Is Nothing Then
  864.     Set PropMouseIcon = Nothing
  865. Else
  866.     If Value.Type = vbPicTypeIcon Or Value.Handle = 0 Then
  867.         Set PropMouseIcon = Value
  868.     Else
  869.         If TextBoxDesignMode = True Then
  870.             MsgBox "Invalid property value", vbCritical + vbOKOnly
  871.             Exit Property
  872.         Else
  873.             ERR.Raise 380
  874.         End If
  875.     End If
  876. End If
  877. UserControl.PropertyChanged "MouseIcon"
  878. End Property

  879. Public Property Get MouseTrack() As Boolean
  880.     MouseTrack = PropMouseTrack
  881. End Property

  882. Public Property Let MouseTrack(ByVal Value As Boolean)
  883.     PropMouseTrack = Value
  884.     UserControl.PropertyChanged "MouseTrack"
  885. End Property

  886. Public Property Get RightToLeft() As Boolean
  887.     RightToLeft = PropRightToLeft
  888. End Property

  889. Public Property Let RightToLeft(ByVal Value As Boolean)
  890.     PropRightToLeft = Value
  891.     UserControl.RightToLeft = PropRightToLeft
  892.     Call ComCtlsCheckRightToLeft(PropRightToLeft, UserControl.RightToLeft, PropRightToLeftMode)
  893.     Dim dwMask As Long
  894.     If PropRightToLeft = True Then dwMask = WS_EX_RTLREADING Or WS_EX_LEFTSCROLLBAR
  895.     If TextBoxHandle <> 0 Then Call ComCtlsSetRightToLeft(TextBoxHandle, dwMask)
  896.     UserControl.PropertyChanged "RightToLeft"
  897. End Property

  898. Public Property Get RightToLeftMode() As CCRightToLeftModeConstants
  899.     RightToLeftMode = PropRightToLeftMode
  900. End Property

  901. Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants)
  902.     Select Case Value
  903.     Case CCRightToLeftModeNoControl, CCRightToLeftModeVBAME, CCRightToLeftModeSystemLocale, CCRightToLeftModeUserLocale, CCRightToLeftModeOSLanguage
  904.         PropRightToLeftMode = Value
  905.     Case Else
  906.         ERR.Raise 380
  907.     End Select
  908.     Me.RightToLeft = PropRightToLeft
  909.     UserControl.PropertyChanged "RightToLeftMode"
  910. End Property

  911. Public Property Get BorderStyle() As CCBorderStyleConstants
  912.     BorderStyle = PropBorderStyle
  913. End Property

  914. Public Property Let BorderStyle(ByVal Value As CCBorderStyleConstants)
  915.     Select Case Value
  916.     Case CCBorderStyleNone, CCBorderStyleSingle, CCBorderStyleThin, CCBorderStyleSunken, CCBorderStyleRaised
  917.         PropBorderStyle = Value
  918.     Case Else
  919.         ERR.Raise 380
  920.     End Select
  921.     If TextBoxHandle <> 0 Then Call ComCtlsChangeBorderStyle(TextBoxHandle, PropBorderStyle)
  922.     UserControl.PropertyChanged "BorderStyle"
  923. End Property

  924. Public Property Get Text() As String
  925.     If TextBoxHandle <> 0 Then
  926.         Text = String(SendMessage(TextBoxHandle, WM_GETTEXTLENGTH, 0, ByVal 0&), vbNullChar)
  927.         SendMessage TextBoxHandle, WM_GETTEXT, Len(Text) + 1, ByVal StrPtr(Text)
  928.     Else
  929.         Text = PropText
  930.     End If
  931. End Property

  932. Public Property Let Text(ByVal Value As String)
  933.     If PropMaxLength > 0 Then Value = Left$(Value, PropMaxLength)
  934.     Dim Changed As Boolean
  935.     Changed = CBool(Me.Text <> Value)
  936.     PropText = Value
  937.     If TextBoxHandle <> 0 Then
  938.         TextBoxChangeFrozen = True
  939.         SendMessage TextBoxHandle, WM_SETTEXT, 0, ByVal StrPtr(PropText)
  940.         TextBoxChangeFrozen = False
  941.     End If
  942.     UserControl.PropertyChanged "Text"
  943.     If Changed = True Then
  944.         On Error Resume Next
  945.         UserControl.Extender.DataChanged = True
  946.         On Error GoTo 0
  947.         RaiseEvent Change
  948.     End If
  949. End Property

  950. Public Property Get Default() As String
  951.     Default = Me.Text
  952. End Property

  953. Public Property Let Default(ByVal Value As String)
  954.     Me.Text = Value
  955. End Property

  956. Public Property Get Alignment() As VBRUN.AlignmentConstants
  957.     Alignment = PropAlignment
  958. End Property

  959. Public Property Let Alignment(ByVal Value As VBRUN.AlignmentConstants)
  960.     Select Case Value
  961.     Case vbLeftJustify, vbCenter, vbRightJustify
  962.         PropAlignment = Value
  963.     Case Else
  964.         ERR.Raise 380
  965.     End Select
  966.     If TextBoxHandle <> 0 Then
  967.         Dim dwStyle As Long
  968.         dwStyle = GetWindowLong(TextBoxHandle, GWL_STYLE)
  969.         If (dwStyle And ES_LEFT) = ES_LEFT Then dwStyle = dwStyle And Not ES_LEFT
  970.         If (dwStyle And ES_CENTER) = ES_CENTER Then dwStyle = dwStyle And Not ES_CENTER
  971.         If (dwStyle And ES_RIGHT) = ES_RIGHT Then dwStyle = dwStyle And Not ES_RIGHT
  972.         Select Case PropAlignment
  973.         Case vbLeftJustify
  974.             dwStyle = dwStyle Or ES_LEFT
  975.         Case vbCenter
  976.             dwStyle = dwStyle Or ES_CENTER
  977.         Case vbRightJustify
  978.             dwStyle = dwStyle Or ES_RIGHT
  979.         End Select
  980.         SetWindowLong TextBoxHandle, GWL_STYLE, dwStyle
  981.         Me.Refresh
  982.     End If
  983.     UserControl.PropertyChanged "Alignment"
  984. End Property

  985. Public Property Get AllowOnlyNumbers() As Boolean
  986.     AllowOnlyNumbers = PropAllowOnlyNumbers
  987. End Property

  988. Public Property Let AllowOnlyNumbers(ByVal Value As Boolean)
  989.     PropAllowOnlyNumbers = Value
  990.     If TextBoxHandle <> 0 Then
  991.         Dim dwStyle As Long
  992.         dwStyle = GetWindowLong(TextBoxHandle, GWL_STYLE)
  993.         If PropAllowOnlyNumbers = True Then
  994.             If Not (dwStyle And ES_NUMBER) = ES_NUMBER Then dwStyle = dwStyle Or ES_NUMBER
  995.         Else
  996.             If (dwStyle And ES_NUMBER) = ES_NUMBER Then dwStyle = dwStyle And Not ES_NUMBER
  997.         End If
  998.         SetWindowLong TextBoxHandle, GWL_STYLE, dwStyle
  999.     End If
  1000.     UserControl.PropertyChanged "AllowOnlyNumbers"
  1001. End Property

  1002. Public Property Get Locked() As Boolean
  1003.     If TextBoxHandle <> 0 Then
  1004.         Locked = CBool((GetWindowLong(TextBoxHandle, GWL_STYLE) And ES_READONLY) <> 0)
  1005.     Else
  1006.         Locked = PropLocked
  1007.     End If
  1008. End Property

  1009. Public Property Let Locked(ByVal Value As Boolean)
  1010.     PropLocked = Value
  1011.     If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SETREADONLY, IIf(PropLocked = True, 1, 0), ByVal 0&
  1012.     UserControl.PropertyChanged "Locked"
  1013. End Property

  1014. Public Property Get HideSelection() As Boolean
  1015.     HideSelection = PropHideSelection
  1016. End Property

  1017. Public Property Let HideSelection(ByVal Value As Boolean)
  1018.     PropHideSelection = Value
  1019.     If TextBoxHandle <> 0 Then Call ReCreateTextBox
  1020.     UserControl.PropertyChanged "HideSelection"
  1021. End Property

  1022. Public Property Get PasswordChar() As String
  1023.     If TextBoxHandle <> 0 Then
  1024.         PasswordChar = ChrW(SendMessage(TextBoxHandle, EM_GETPASSWORDCHAR, 0, ByVal 0&))
  1025.     Else
  1026.         PasswordChar = ChrW(PropPasswordChar)
  1027.     End If
  1028. End Property

  1029. Public Property Let PasswordChar(ByVal Value As String)
  1030.     If PropUseSystemPasswordChar = True Then Exit Property
  1031.     If Value = vbNullString Or Len(Value) = 0 Then
  1032.         PropPasswordChar = 0
  1033.     ElseIf Len(Value) = 1 Then
  1034.         PropPasswordChar = AscW(Value)
  1035.     Else
  1036.         If TextBoxDesignMode = True Then
  1037.             MsgBox "Invalid property value", vbCritical + vbOKOnly
  1038.             Exit Property
  1039.         Else
  1040.             ERR.Raise 380
  1041.         End If
  1042.     End If
  1043.     If TextBoxHandle <> 0 Then
  1044.         SendMessage TextBoxHandle, EM_SETPASSWORDCHAR, PropPasswordChar, ByVal 0&
  1045.         Me.Refresh
  1046.     End If
  1047.     UserControl.PropertyChanged "PasswordChar"
  1048. End Property

  1049. Public Property Get UseSystemPasswordChar() As Boolean
  1050.     UseSystemPasswordChar = PropUseSystemPasswordChar
  1051. End Property

  1052. Public Property Let UseSystemPasswordChar(ByVal Value As Boolean)
  1053.     PropUseSystemPasswordChar = Value
  1054.     If TextBoxHandle <> 0 Then Call ReCreateTextBox
  1055.     UserControl.PropertyChanged "UseSystemPasswordChar"
  1056. End Property

  1057. Public Property Get MultiLine() As Boolean
  1058.     MultiLine = PropMultiLine
  1059. End Property

  1060. Public Property Let MultiLine(ByVal Value As Boolean)
  1061.     PropMultiLine = Value
  1062.     If TextBoxHandle <> 0 Then Call ReCreateTextBox
  1063.     UserControl.PropertyChanged "MultiLine"
  1064. End Property

  1065. Public Property Get MaxLength() As Long
  1066.     MaxLength = PropMaxLength
  1067. End Property

  1068. Public Property Let MaxLength(ByVal Value As Long)
  1069.     If Value < 0 Then
  1070.         If TextBoxDesignMode = True Then
  1071.             MsgBox "Invalid property value", vbCritical + vbOKOnly
  1072.             Exit Property
  1073.         Else
  1074.             ERR.Raise 380
  1075.         End If
  1076.     End If
  1077.     PropMaxLength = Value
  1078.     If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SETLIMITTEXT, PropMaxLength, ByVal 0&
  1079.     UserControl.PropertyChanged "MaxLength"
  1080. End Property

  1081. Public Property Get ScrollBars() As VBRUN.ScrollBarConstants
  1082.     ScrollBars = PropScrollBars
  1083. End Property

  1084. Public Property Let ScrollBars(ByVal Value As VBRUN.ScrollBarConstants)
  1085.     Select Case Value
  1086.     Case vbSBNone, vbHorizontal, vbVertical, vbBoth
  1087.         PropScrollBars = Value
  1088.         If TextBoxHandle <> 0 Then Call ReCreateTextBox
  1089.     Case Else
  1090.         ERR.Raise 380
  1091.     End Select
  1092.     UserControl.PropertyChanged "ScrollBars"
  1093. End Property

  1094. Public Property Get CueBanner() As String
  1095.     CueBanner = PropCueBanner
  1096. End Property

  1097. Public Property Let CueBanner(ByVal Value As String)
  1098.     PropCueBanner = Value
  1099.     If TextBoxHandle <> 0 And PropMultiLine = False And ComCtlsSupportLevel() >= 1 Then SendMessage TextBoxHandle, EM_SETCUEBANNER, 0, ByVal StrPtr(PropCueBanner)
  1100.     UserControl.PropertyChanged "CueBanner"
  1101. End Property

  1102. Public Property Get CharacterCasing() As TxtCharacterCasingConstants
  1103.     CharacterCasing = PropCharacterCasing
  1104. End Property

  1105. Public Property Let CharacterCasing(ByVal Value As TxtCharacterCasingConstants)
  1106.     Select Case Value
  1107.     Case TxtCharacterCasingNormal, TxtCharacterCasingUpper, TxtCharacterCasingLower
  1108.         PropCharacterCasing = Value
  1109.     Case Else
  1110.         ERR.Raise 380
  1111.     End Select
  1112.     If TextBoxHandle <> 0 Then
  1113.         Dim dwStyle As Long
  1114.         dwStyle = GetWindowLong(TextBoxHandle, GWL_STYLE)
  1115.         If (dwStyle And ES_UPPERCASE) = ES_UPPERCASE Then dwStyle = dwStyle And Not ES_UPPERCASE
  1116.         If (dwStyle And ES_LOWERCASE) = ES_LOWERCASE Then dwStyle = dwStyle And Not ES_LOWERCASE
  1117.         Select Case PropCharacterCasing
  1118.         Case TxtCharacterCasingUpper
  1119.             dwStyle = dwStyle Or ES_UPPERCASE
  1120.         Case TxtCharacterCasingLower
  1121.             dwStyle = dwStyle Or ES_LOWERCASE
  1122.         End Select
  1123.         SetWindowLong TextBoxHandle, GWL_STYLE, dwStyle
  1124.         If TextBoxDesignMode = True Then
  1125.             SendMessage TextBoxHandle, WM_SETTEXT, 0, ByVal 0&
  1126.             SendMessage TextBoxHandle, WM_SETTEXT, 0, ByVal StrPtr(PropText)
  1127.         End If
  1128.     End If
  1129.     UserControl.PropertyChanged "CharacterCasing"
  1130. End Property

  1131. Public Property Get WantReturn() As Boolean
  1132.     WantReturn = PropWantReturn
  1133. End Property

  1134. Public Property Let WantReturn(ByVal Value As Boolean)
  1135.     If PropWantReturn = Value Then Exit Property
  1136.     PropWantReturn = Value
  1137.     If TextBoxHandle <> 0 And TextBoxDesignMode = False Then
  1138.         ' It is not possible (in VB6) to achieve this when specifying ES_WANTRETURN.
  1139.         Call OnControlInfoChanged(Me, CBool(GetFocus() = TextBoxHandle))
  1140.     End If
  1141.     UserControl.PropertyChanged "WantReturn"
  1142. End Property

  1143. Public Property Get IMEMode() As CCIMEModeConstants
  1144.     IMEMode = PropIMEMode
  1145. End Property

  1146. Public Property Let IMEMode(ByVal Value As CCIMEModeConstants)
  1147.     Select Case Value
  1148.     Case CCIMEModeNoControl, CCIMEModeOn, CCIMEModeOff, CCIMEModeDisable, CCIMEModeHiragana, CCIMEModeKatakana, CCIMEModeKatakanaHalf, CCIMEModeAlphaFull, CCIMEModeAlpha, CCIMEModeHangulFull, CCIMEModeHangul
  1149.         PropIMEMode = Value
  1150.     Case Else
  1151.         ERR.Raise 380
  1152.     End Select
  1153.     If TextBoxHandle <> 0 And TextBoxDesignMode = False Then
  1154.         If GetFocus() = TextBoxHandle Then Call ComCtlsSetIMEMode(TextBoxHandle, TextBoxIMCHandle, PropIMEMode)
  1155.     End If
  1156.     UserControl.PropertyChanged "IMEMode"
  1157. End Property

  1158. Public Property Get NetAddressValidator() As Boolean
  1159.     NetAddressValidator = PropNetAddressValidator
  1160. End Property

  1161. Public Property Let NetAddressValidator(ByVal Value As Boolean)
  1162.     PropNetAddressValidator = Value
  1163.     If TextBoxHandle <> 0 And ComCtlsSupportLevel() >= 2 Then
  1164.         TextBoxNetAddressFormat = TxtNetAddressFormatNone
  1165.         TextBoxNetAddressString = vbNullString
  1166.         TextBoxNetAddressPortNumber = 0
  1167.         TextBoxNetAddressPrefixLength = 0
  1168.         Call ReCreateTextBox
  1169.     End If
  1170.     UserControl.PropertyChanged "NetAddressValidator"
  1171. End Property

  1172. Public Property Get NetAddressType() As TxtNetAddressTypeConstants
  1173.     NetAddressType = PropNetAddressType
  1174. End Property

  1175. Public Property Let NetAddressType(ByVal Value As TxtNetAddressTypeConstants)
  1176.     Select Case Value
  1177.     Case TxtNetAddressTypeNone, TxtNetAddressTypeIPv4Address, TxtNetAddressTypeIPv4Service, TxtNetAddressTypeIPv4Network, TxtNetAddressTypeIPv6Address, TxtNetAddressTypeIPv6AddressNoScope, TxtNetAddressTypeIPv6Service, TxtNetAddressTypeIPv6ServiceNoScope, TxtNetAddressTypeIPv6Network, TxtNetAddressTypeDNSName, TxtNetAddressTypeDNSService, TxtNetAddressTypeIPAddress, TxtNetAddressTypeIPAddressNoScope, TxtNetAddressTypeIPService, TxtNetAddressTypeIPServiceNoScope, TxtNetAddressTypeIPNetwork, TxtNetAddressTypeAnyAddress, TxtNetAddressTypeAnyAddressNoScope, TxtNetAddressTypeAnyService, TxtNetAddressTypeAnyServiceNoScope
  1178.         PropNetAddressType = Value
  1179.     Case Else
  1180.         ERR.Raise 380
  1181.     End Select
  1182.     If TextBoxHandle <> 0 And PropNetAddressValidator = True And ComCtlsSupportLevel() >= 2 Then
  1183.         Dim AddrMask As Long
  1184.         Select Case PropNetAddressType
  1185.         Case TxtNetAddressTypeNone
  1186.             AddrMask = 0
  1187.         Case TxtNetAddressTypeIPv4Address
  1188.             AddrMask = NET_STRING_IPV4_ADDRESS
  1189.         Case TxtNetAddressTypeIPv4Service
  1190.             AddrMask = NET_STRING_IPV4_SERVICE
  1191.         Case TxtNetAddressTypeIPv4Network
  1192.             AddrMask = NET_STRING_IPV4_NETWORK
  1193.         Case TxtNetAddressTypeIPv6Address
  1194.             AddrMask = NET_STRING_IPV6_ADDRESS
  1195.         Case TxtNetAddressTypeIPv6AddressNoScope
  1196.             AddrMask = NET_STRING_IPV6_ADDRESS_NO_SCOPE
  1197.         Case TxtNetAddressTypeIPv6Service
  1198.             AddrMask = NET_STRING_IPV6_SERVICE
  1199.         Case TxtNetAddressTypeIPv6ServiceNoScope
  1200.             AddrMask = NET_STRING_IPV6_SERVICE_NO_SCOPE
  1201.         Case TxtNetAddressTypeIPv6Network
  1202.             AddrMask = NET_STRING_IPV6_NETWORK
  1203.         Case TxtNetAddressTypeDNSName
  1204.             AddrMask = NET_STRING_NAMED_ADDRESS
  1205.         Case TxtNetAddressTypeDNSService
  1206.             AddrMask = NET_STRING_NAMED_SERVICE
  1207.         Case TxtNetAddressTypeIPAddress
  1208.             AddrMask = NET_STRING_IP_ADDRESS
  1209.         Case TxtNetAddressTypeIPAddressNoScope
  1210.             AddrMask = NET_STRING_IP_ADDRESS_NO_SCOPE
  1211.         Case TxtNetAddressTypeIPService
  1212.             AddrMask = NET_STRING_IP_SERVICE
  1213.         Case TxtNetAddressTypeIPServiceNoScope
  1214.             AddrMask = NET_STRING_IP_SERVICE_NO_SCOPE
  1215.         Case TxtNetAddressTypeIPNetwork
  1216.             AddrMask = NET_STRING_IP_NETWORK
  1217.         Case TxtNetAddressTypeAnyAddress
  1218.             AddrMask = NET_STRING_ANY_ADDRESS
  1219.         Case TxtNetAddressTypeAnyAddressNoScope
  1220.             AddrMask = NET_STRING_ANY_ADDRESS_NO_SCOPE
  1221.         Case TxtNetAddressTypeAnyService
  1222.             AddrMask = NET_STRING_ANY_SERVICE
  1223.         Case TxtNetAddressTypeAnyServiceNoScope
  1224.             AddrMask = NET_STRING_ANY_SERVICE_NO_SCOPE
  1225.         End Select
  1226.         SendMessage TextBoxHandle, NCM_SETALLOWTYPE, AddrMask, ByVal 0&
  1227.     End If
  1228.     UserControl.PropertyChanged "NetAddressType"
  1229. End Property

  1230. Public Property Get AllowOverType() As Boolean
  1231.     AllowOverType = PropAllowOverType
  1232. End Property

  1233. Public Property Let AllowOverType(ByVal Value As Boolean)
  1234.     PropAllowOverType = Value
  1235.     If PropAllowOverType = False Then Me.OverTypeMode = False
  1236.     UserControl.PropertyChanged "AllowOverType"
  1237. End Property

  1238. Public Property Get OverTypeMode() As Boolean
  1239.     OverTypeMode = PropOverTypeMode
  1240. End Property

  1241. Public Property Let OverTypeMode(ByVal Value As Boolean)
  1242.     If PropOverTypeMode = Value Then Exit Property
  1243.     If PropAllowOverType = True Then PropOverTypeMode = Value Else PropOverTypeMode = False
  1244.     UserControl.PropertyChanged "OverTypeMode"
  1245. End Property

  1246. Private Sub CreateTextBox()
  1247.     If TextBoxHandle <> 0 Then Exit Sub
  1248.     Dim dwStyle As Long, dwExStyle As Long
  1249.     dwStyle = WS_CHILD Or WS_VISIBLE
  1250.     If PropRightToLeft = True Then dwExStyle = WS_EX_RTLREADING Or WS_EX_LEFTSCROLLBAR
  1251.     Call ComCtlsInitBorderStyle(dwStyle, dwExStyle, PropBorderStyle)
  1252.     If PropAllowOnlyNumbers = True Then dwStyle = dwStyle Or ES_NUMBER
  1253.     If PropRightToLeft = False Then dwStyle = dwStyle Or ES_LEFT Else dwStyle = dwStyle Or ES_RIGHT
  1254.     If PropLocked = True Then dwStyle = dwStyle Or ES_READONLY
  1255.     If PropHideSelection = False Then dwStyle = dwStyle Or ES_NOHIDESEL
  1256.     If PropUseSystemPasswordChar = True Then dwStyle = dwStyle Or ES_PASSWORD
  1257.     If PropMultiLine = True Then
  1258.         dwStyle = dwStyle Or ES_MULTILINE
  1259.         Select Case PropScrollBars
  1260.         Case vbSBNone
  1261.             dwStyle = dwStyle Or ES_AUTOVSCROLL
  1262.         Case vbHorizontal
  1263.             dwStyle = dwStyle Or WS_HSCROLL Or ES_AUTOVSCROLL Or ES_AUTOHSCROLL
  1264.         Case vbVertical
  1265.             dwStyle = dwStyle Or WS_VSCROLL Or ES_AUTOVSCROLL
  1266.         Case vbBoth
  1267.             dwStyle = dwStyle Or WS_HSCROLL Or WS_VSCROLL Or ES_AUTOVSCROLL Or ES_AUTOHSCROLL
  1268.         End Select
  1269.     Else
  1270.         dwStyle = dwStyle Or ES_AUTOHSCROLL
  1271.     End If
  1272.     Select Case PropCharacterCasing
  1273.     Case TxtCharacterCasingUpper
  1274.         dwStyle = dwStyle Or ES_UPPERCASE
  1275.     Case TxtCharacterCasingLower
  1276.         dwStyle = dwStyle Or ES_LOWERCASE
  1277.     End Select
  1278.     If PropNetAddressValidator = True And ComCtlsSupportLevel() >= 2 Then
  1279.         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&)
  1280.     End If
  1281.     If TextBoxHandle = 0 Then TextBoxHandle = CreateWindowEx(dwExStyle, StrPtr("Edit"), 0, dwStyle, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight, UserControl.hwnd, 0, App.hInstance, ByVal 0&)
  1282.     If TextBoxHandle <> 0 Then
  1283.         If PropPasswordChar <> 0 And PropUseSystemPasswordChar = False Then SendMessage TextBoxHandle, EM_SETPASSWORDCHAR, PropPasswordChar, ByVal 0&
  1284.         SendMessage TextBoxHandle, EM_SETLIMITTEXT, PropMaxLength, ByVal 0&
  1285.         SendMessage TextBoxHandle, WM_SETTEXT, 0, ByVal StrPtr(PropText)
  1286.     End If
  1287.     Set Me.Font = PropFont
  1288.     Me.VisualStyles = PropVisualStyles
  1289.     Me.Enabled = UserControl.Enabled
  1290.     Me.Alignment = PropAlignment
  1291.     If Not PropCueBanner = vbNullString Then Me.CueBanner = PropCueBanner
  1292.     If PropNetAddressValidator = True Then Me.NetAddressType = PropNetAddressType
  1293.     If TextBoxDesignMode = False Then
  1294.         If TextBoxHandle <> 0 Then Call ComCtlsSetSubclass(TextBoxHandle, Me, 1)
  1295.         Call ComCtlsSetSubclass(UserControl.hwnd, Me, 2)
  1296.         If TextBoxHandle <> 0 Then Call ComCtlsCreateIMC(TextBoxHandle, TextBoxIMCHandle)
  1297.     End If
  1298. End Sub

  1299. Private Sub ReCreateTextBox()
  1300.     If TextBoxDesignMode = False Then
  1301.         Dim Locked As Boolean
  1302.         Locked = CBool(LockWindowUpdate(UserControl.hwnd) <> 0)
  1303.         Dim SelStart As Long, SelEnd As Long
  1304.         Dim ScrollPosHorz As Integer, ScrollPosVert As Integer
  1305.         If TextBoxHandle <> 0 Then
  1306.             SendMessage TextBoxHandle, EM_GETSEL, VarPtr(SelStart), ByVal VarPtr(SelEnd)
  1307.             If PropMultiLine = True And PropScrollBars <> vbSBNone Then
  1308.                 If PropScrollBars = vbHorizontal Or PropScrollBars = vbBoth Then
  1309.                     ScrollPosHorz = CUIntToInt(GetScrollPos(TextBoxHandle, SB_HORZ) And &HFFFF&)
  1310.                 End If
  1311.                 If PropScrollBars = vbVertical Or PropScrollBars = vbBoth Then
  1312.                     ScrollPosVert = CUIntToInt(GetScrollPos(TextBoxHandle, SB_VERT) And &HFFFF&)
  1313.                 End If
  1314.             End If
  1315.             Dim Buffer As String
  1316.             Buffer = String(SendMessage(TextBoxHandle, WM_GETTEXTLENGTH, 0, ByVal 0&), vbNullChar)
  1317.             SendMessage TextBoxHandle, WM_GETTEXT, Len(Buffer) + 1, ByVal StrPtr(Buffer)
  1318.             PropText = Buffer
  1319.         End If
  1320.         Call DestroyTextBox
  1321.         Call CreateTextBox
  1322.         Call UserControl_Resize
  1323.         If TextBoxHandle <> 0 Then
  1324.             SendMessage TextBoxHandle, EM_SETSEL, SelStart, ByVal SelEnd
  1325.             If ScrollPosHorz > 0 Then SendMessage TextBoxHandle, WM_HSCROLL, MakeDWord(SB_THUMBPOSITION, ScrollPosHorz), ByVal 0&
  1326.             If ScrollPosVert > 0 Then SendMessage TextBoxHandle, WM_VSCROLL, MakeDWord(SB_THUMBPOSITION, ScrollPosVert), ByVal 0&
  1327.         End If
  1328.         If Locked = True Then LockWindowUpdate 0
  1329.         Me.Refresh
  1330.     Else
  1331.         Call DestroyTextBox
  1332.         Call CreateTextBox
  1333.         Call UserControl_Resize
  1334.     End If
  1335. End Sub

  1336. Private Sub DestroyTextBox()
  1337.     If TextBoxHandle = 0 Then Exit Sub
  1338.     Call ComCtlsRemoveSubclass(TextBoxHandle)
  1339.     Call ComCtlsRemoveSubclass(UserControl.hwnd)
  1340.     Call ComCtlsDestroyIMC(TextBoxHandle, TextBoxIMCHandle)
  1341.     ShowWindow TextBoxHandle, SW_HIDE
  1342.     SetParent TextBoxHandle, 0
  1343.     DestroyWindow TextBoxHandle
  1344.     TextBoxHandle = 0
  1345.     If TextBoxFontHandle <> 0 Then
  1346.         DeleteObject TextBoxFontHandle
  1347.         TextBoxFontHandle = 0
  1348.     End If
  1349. End Sub

  1350. Public Sub Refresh()
  1351.     UserControl.Refresh
  1352.     RedrawWindow UserControl.hwnd, 0, 0, RDW_UPDATENOW Or RDW_INVALIDATE Or RDW_ERASE Or RDW_ALLCHILDREN
  1353. End Sub

  1354. Public Sub Copy()
  1355.     If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, WM_COPY, 0, ByVal 0&
  1356. End Sub

  1357. Public Sub Cut()
  1358.     If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, WM_CUT, 0, ByVal 0&
  1359. End Sub

  1360. Public Sub Paste()
  1361.     If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, WM_PASTE, 0, ByVal 0&
  1362. End Sub

  1363. Public Sub Clear()
  1364.     If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, WM_CLEAR, 0, ByVal 0&
  1365. End Sub

  1366. Public Sub Undo()
  1367.     If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_UNDO, 0, ByVal 0&
  1368. End Sub

  1369. Public Function CanUndo() As Boolean
  1370.     If TextBoxHandle <> 0 Then CanUndo = CBool(SendMessage(TextBoxHandle, EM_CANUNDO, 0, ByVal 0&) <> 0)
  1371. End Function

  1372. Public Sub ResetUndoFlag()
  1373.     If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_EMPTYUNDOBUFFER, 0, ByVal 0&
  1374. End Sub

  1375. Public Property Get Modified() As Boolean
  1376.     If TextBoxHandle <> 0 Then Modified = CBool(SendMessage(TextBoxHandle, EM_GETMODIFY, 0, ByVal 0&) <> 0)
  1377. End Property

  1378. Public Property Let Modified(ByVal Value As Boolean)
  1379.     If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SETMODIFY, IIf(Value = True, 1, 0), ByVal 0&
  1380. End Property

  1381. Public Property Get SelStart() As Long
  1382.     If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_GETSEL, VarPtr(SelStart), ByVal 0&
  1383. End Property

  1384. Public Property Let SelStart(ByVal Value As Long)
  1385.     If TextBoxHandle <> 0 Then
  1386.         If Value >= 0 Then
  1387.             SendMessage TextBoxHandle, EM_SETSEL, Value, ByVal Value
  1388.         Else
  1389.             ERR.Raise 380
  1390.         End If
  1391.     End If
  1392. End Property

  1393. Public Property Get SelLength() As Long
  1394.     If TextBoxHandle <> 0 Then
  1395.         Dim SelStart As Long, SelEnd As Long
  1396.         SendMessage TextBoxHandle, EM_GETSEL, VarPtr(SelStart), ByVal VarPtr(SelEnd)
  1397.         SelLength = SelEnd - SelStart
  1398.     End If
  1399. End Property

  1400. Public Property Let SelLength(ByVal Value As Long)
  1401.     If TextBoxHandle <> 0 Then
  1402.         If Value >= 0 Then
  1403.             Dim SelStart As Long
  1404.             SendMessage TextBoxHandle, EM_GETSEL, VarPtr(SelStart), ByVal 0&
  1405.             SendMessage TextBoxHandle, EM_SETSEL, SelStart, ByVal SelStart + Value
  1406.         Else
  1407.             ERR.Raise 380
  1408.         End If
  1409.     End If
  1410. End Property

  1411. Public Property Get SelText() As String
  1412.     If TextBoxHandle <> 0 Then
  1413.         Dim SelStart As Long, SelEnd As Long
  1414.         SendMessage TextBoxHandle, EM_GETSEL, VarPtr(SelStart), ByVal VarPtr(SelEnd)
  1415.         On Error Resume Next
  1416.         SelText = Mid$(Me.Text, SelStart + 1, (SelEnd - SelStart))
  1417.         On Error GoTo 0
  1418.     End If
  1419. End Property

  1420. Public Property Let SelText(ByVal Value As String)
  1421.     If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_REPLACESEL, 1, ByVal StrPtr(Value)
  1422. End Property

  1423. Public Function GetLine(ByVal LineNumber As Long) As String
  1424.     If LineNumber < 0 Then ERR.Raise 380
  1425.     If TextBoxHandle <> 0 Then
  1426.         Dim FirstCharPos As Long, Length As Long
  1427.         FirstCharPos = SendMessage(TextBoxHandle, EM_LINEINDEX, LineNumber - 1, ByVal 0&)
  1428.         If FirstCharPos > -1 Then
  1429.             Length = SendMessage(TextBoxHandle, EM_LINELENGTH, FirstCharPos, ByVal 0&)
  1430.             If Length > 0 Then
  1431.                 Dim Buffer As String
  1432.                 Buffer = ChrW(Length) & String(Length - 1, vbNullChar)
  1433.                 If LineNumber > 0 Then
  1434.                     If SendMessage(TextBoxHandle, EM_GETLINE, LineNumber - 1, ByVal StrPtr(Buffer)) > 0 Then GetLine = Buffer
  1435.                 Else
  1436.                     If SendMessage(TextBoxHandle, EM_GETLINE, SendMessage(TextBoxHandle, EM_LINEFROMCHAR, FirstCharPos, ByVal 0&), ByVal StrPtr(Buffer)) > 0 Then GetLine = Buffer
  1437.                 End If
  1438.             End If
  1439.         Else
  1440.             ERR.Raise 380
  1441.         End If
  1442.     End If
  1443. End Function

  1444. Public Function GetLineCount() As Long
  1445.     If TextBoxHandle <> 0 Then GetLineCount = SendMessage(TextBoxHandle, EM_GETLINECOUNT, 0, ByVal 0&)
  1446. End Function

  1447. Public Sub ScrollToLine(ByVal LineNumber As Long)
  1448.     If LineNumber < 0 Then ERR.Raise 380
  1449.     If TextBoxHandle <> 0 Then
  1450.         If SendMessage(TextBoxHandle, EM_LINEINDEX, LineNumber - 1, ByVal 0&) > -1 Then
  1451.             Dim LineIndex As Long
  1452.             LineIndex = SendMessage(TextBoxHandle, EM_GETFIRSTVISIBLELINE, 0, ByVal 0&)
  1453.             SendMessage TextBoxHandle, EM_LINESCROLL, 0, ByVal CLng((LineNumber - 1) - LineIndex)
  1454.         Else
  1455.             ERR.Raise 380
  1456.         End If
  1457.     End If
  1458. End Sub

  1459. Public Sub ScrollToCaret()
  1460.     If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SCROLLCARET, 0, ByVal 0&
  1461. End Sub

  1462. Public Function CharFromPos(ByVal X As Single, ByVal Y As Single) As Long
  1463.     Dim p As POINTAPI
  1464.     p.X = UserControl.ScaleX(X, vbContainerPosition, vbPixels)
  1465.     p.Y = UserControl.ScaleY(Y, vbContainerPosition, vbPixels)
  1466.     If TextBoxHandle <> 0 Then CharFromPos = CIntToUInt(LoWord(SendMessage(TextBoxHandle, EM_CHARFROMPOS, 0, ByVal MakeDWord(p.X, p.Y))))
  1467. End Function

  1468. Public Function GetLineFromChar(ByVal CharIndex As Long) As Long
  1469.     If CharIndex < -1 Then ERR.Raise 380
  1470.     If TextBoxHandle <> 0 Then GetLineFromChar = SendMessage(TextBoxHandle, EM_LINEFROMCHAR, CharIndex, ByVal 0&) + 1
  1471. End Function

  1472. Public Function ShowBalloonTip(ByVal Text As String, Optional ByVal Title As String, Optional ByVal Icon As TxtIconConstants) As Boolean
  1473.     If TextBoxHandle <> 0 And ComCtlsSupportLevel() >= 1 Then
  1474.         Dim EDITBT As EDITBALLOONTIP
  1475.         With EDITBT
  1476.             .cbStruct = LenB(EDITBT)
  1477.             .pszText = StrPtr(Text)
  1478.             .pszTitle = StrPtr(Title)
  1479.             Select Case Icon
  1480.             Case TxtIconNone, TxtIconInfo, TxtIconWarning, TxtIconError
  1481.                 .iIcon = Icon
  1482.             Case Else
  1483.                 ERR.Raise 380
  1484.             End Select
  1485.             If GetFocus() <> TextBoxHandle Then SetFocusAPI UserControl.hwnd
  1486.             ShowBalloonTip = CBool(SendMessage(TextBoxHandle, EM_SHOWBALLOONTIP, 0, ByVal VarPtr(EDITBT)) <> 0)
  1487.         End With
  1488.     End If
  1489. End Function

  1490. Public Function HideBalloonTip() As Boolean
  1491.     If TextBoxHandle <> 0 And ComCtlsSupportLevel() >= 1 Then HideBalloonTip = CBool(SendMessage(TextBoxHandle, EM_HIDEBALLOONTIP, 0, ByVal 0&) <> 0)
  1492. End Function

  1493. Public Property Get LeftMargin() As Single
  1494.     If TextBoxHandle <> 0 Then LeftMargin = UserControl.ScaleX(LoWord(SendMessage(TextBoxHandle, EM_GETMARGINS, 0, ByVal 0&)), vbPixels, vbContainerSize)
  1495. End Property

  1496. Public Property Let LeftMargin(ByVal Value As Single)
  1497.     If Value = EC_USEFONTINFO Or Value = -1 Then
  1498.         If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SETMARGINS, EC_LEFTMARGIN, ByVal EC_USEFONTINFO
  1499.     Else
  1500.         If Value < 0 Then ERR.Raise 380
  1501.         Dim IntValue As Integer
  1502.         IntValue = CInt(UserControl.ScaleX(Value, vbContainerSize, vbPixels))
  1503.         If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SETMARGINS, EC_LEFTMARGIN, ByVal MakeDWord(IntValue, 0)
  1504.     End If
  1505. End Property

  1506. Public Property Get RightMargin() As Single
  1507.     If TextBoxHandle <> 0 Then RightMargin = UserControl.ScaleX(HiWord(SendMessage(TextBoxHandle, EM_GETMARGINS, 0, ByVal 0&)), vbPixels, vbContainerSize)
  1508. End Property

  1509. Public Property Let RightMargin(ByVal Value As Single)
  1510.     If Value = EC_USEFONTINFO Or Value = -1 Then
  1511.         If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SETMARGINS, EC_RIGHTMARGIN, ByVal EC_USEFONTINFO
  1512.     Else
  1513.         If Value < 0 Then ERR.Raise 380
  1514.         Dim IntValue As Integer
  1515.         IntValue = CInt(UserControl.ScaleX(Value, vbContainerSize, vbPixels))
  1516.         If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SETMARGINS, EC_RIGHTMARGIN, ByVal MakeDWord(0, IntValue)
  1517.     End If
  1518. End Property

  1519. Public Sub ValidateNetAddress()
  1520.     TextBoxNetAddressFormat = TxtNetAddressFormatNone
  1521.     TextBoxNetAddressString = vbNullString
  1522.     TextBoxNetAddressPortNumber = 0
  1523.     TextBoxNetAddressPrefixLength = 0
  1524.     If TextBoxHandle <> 0 And PropNetAddressValidator = True Then
  1525.         If ComCtlsSupportLevel() >= 2 Then
  1526.             Dim NCADDR As NC_ADDRESS, NETADDRINFO_UNSPECIFIED As NET_ADDRESS_INFO_UNSPECIFIED, ErrVal As Long
  1527.             NCADDR.pAddrInfo = VarPtr(NETADDRINFO_UNSPECIFIED)
  1528.             ErrVal = SendMessage(TextBoxHandle, NCM_GETADDRESS, 0, ByVal VarPtr(NCADDR))
  1529.             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
  1530.             Select Case ErrVal
  1531.             Case ERROR_SUCCESS
  1532.                 TextBoxNetAddressFormat = NETADDRINFO_UNSPECIFIED.Format
  1533.                 TextBoxNetAddressPortNumber = NCADDR.PortNumber
  1534.                 TextBoxNetAddressPrefixLength = NCADDR.PrefixLength
  1535.                 Select Case NETADDRINFO_UNSPECIFIED.Format
  1536.                 Case NET_ADDRESS_FORMAT_UNSPECIFIED
  1537.                     ERR.Raise Number:=380, Description:="The network address format is not provided."
  1538.                 Case NET_ADDRESS_DNS_NAME
  1539.                     Dim NETADDRINFO_DNSNAME As NET_ADDRESS_INFO_DNS_NAME
  1540.                     CopyMemory ByVal VarPtr(NETADDRINFO_DNSNAME), NETADDRINFO_UNSPECIFIED.data(0), LenB(NETADDRINFO_DNSNAME)
  1541.                     TextBoxNetAddressString = Left$(NETADDRINFO_DNSNAME.Address(), InStr(NETADDRINFO_DNSNAME.Address(), vbNullChar) - 1)
  1542.                 Case NET_ADDRESS_IPV4
  1543.                     Dim NETADDRINFO_IPV4 As NET_ADDRESS_INFO_IPV4
  1544.                     CopyMemory ByVal VarPtr(NETADDRINFO_IPV4), NETADDRINFO_UNSPECIFIED.data(0), LenB(NETADDRINFO_IPV4)
  1545.                     With NETADDRINFO_IPV4
  1546.                         TextBoxNetAddressString = HiByte(HiWord(.sin_addr)) & "." & LoByte(HiWord(.sin_addr)) & "." & HiByte(LoWord(.sin_addr)) & "." & LoByte(LoWord(.sin_addr))
  1547.                     End With
  1548.                 Case NET_ADDRESS_IPV6
  1549.                     Dim NETADDRINFO_IPV6 As NET_ADDRESS_INFO_IPV6, Buffer As String, Temp As String, i As Long
  1550.                     CopyMemory ByVal VarPtr(NETADDRINFO_IPV6), NETADDRINFO_UNSPECIFIED.data(0), LenB(NETADDRINFO_IPV6)
  1551.                     With NETADDRINFO_IPV6
  1552.                         For i = 1 To 8
  1553.                             Temp = Format(Hex(LoByte(.sin6_addr(i - 1))), "00") & Format(Hex(HiByte(.sin6_addr(i - 1))), "00")
  1554.                             Do While Left$(Temp, 1) = "0"
  1555.                                 If Len(Temp) = 1 Then Exit Do
  1556.                                 Temp = Mid$(Temp, 2)
  1557.                             Loop
  1558.                             Buffer = Buffer & Temp & ":"
  1559.                         Next i
  1560.                         TextBoxNetAddressString = Mid$(Buffer, 1, Len(Buffer) - 1) ' Uncompressed IPv6 format
  1561.                     End With
  1562.                 Case Else
  1563.                     ERR.Raise Number:=380, Description:="The network address format is unspecified."
  1564.                 End Select
  1565.             Case S_FALSE
  1566.                 ERR.Raise Number:=380, Description:="There is no network address string to validate."
  1567.             Case ERROR_INSUFFICIENT_BUFFER
  1568.                 ERR.Raise Number:=ERROR_INSUFFICIENT_BUFFER, Description:="The out buffer is too small to hold the parsed network address."
  1569.             Case ERROR_INVALID_PARAMETER
  1570.                 ERR.Raise Number:=ERROR_INVALID_PARAMETER, Description:="The network address string is not of any type specified."
  1571.             Case E_INVALIDARG
  1572.                 ERR.Raise Number:=E_INVALIDARG, Description:="The network address string is invalid."
  1573.             Case Else
  1574.                 ERR.Raise Number:=ErrVal, Description:="Unexpected error."
  1575.             End Select
  1576.         Else
  1577.             ERR.Raise Number:=5, Description:="To use this functionality, you must provide a manifest specifying comctl32.dll version 6.1 or higher."
  1578.         End If
  1579.     Else
  1580.         ERR.Raise Number:=5, Description:="Procedure call can't be carried out as property NetAddressValidator is False."
  1581.     End If
  1582. End Sub

  1583. Public Sub ShowNetAddressErrorTip()
  1584.     If TextBoxHandle <> 0 And PropNetAddressValidator = True And ComCtlsSupportLevel() >= 2 Then
  1585.         If GetFocus() <> TextBoxHandle Then SetFocusAPI UserControl.hwnd
  1586.         SendMessage TextBoxHandle, NCM_DISPLAYERRORTIP, 0, ByVal 0&
  1587.     End If
  1588. End Sub

  1589. Public Property Get NetAddressFormat() As TxtNetAddressFormatConstants
  1590. NetAddressFormat = TextBoxNetAddressFormat
  1591. End Property

  1592. Public Property Get NetAddressString() As String
  1593. NetAddressString = TextBoxNetAddressString
  1594. End Property

  1595. Public Property Get NetAddressPortNumber() As Integer
  1596. NetAddressPortNumber = TextBoxNetAddressPortNumber
  1597. End Property

  1598. Public Property Get NetAddressPrefixLength() As Byte
  1599. NetAddressPrefixLength = TextBoxNetAddressPrefixLength
  1600. End Property

  1601. 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
  1602.     Select Case dwRefData
  1603.     Case 1
  1604.         ISubclass_Message = WindowProcControl(hwnd, wMsg, wParam, lParam)
  1605.     Case 2
  1606.         ISubclass_Message = WindowProcUserControl(hwnd, wMsg, wParam, lParam)
  1607.     End Select
  1608. End Function

  1609. Private Function WindowProcControl(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  1610.     Select Case wMsg
  1611.     Case WM_SETFOCUS
  1612.         If wParam <> UserControl.hwnd Then SetFocusAPI UserControl.hwnd: Exit Function
  1613.         Call ActivateIPAO(Me)
  1614.     Case WM_KILLFOCUS
  1615.         Call DeActivateIPAO
  1616.     Case WM_SETCURSOR
  1617.         If LoWord(lParam) = HTCLIENT Then
  1618.             If PropOLEDragMode = vbOLEDragAutomatic Then
  1619.                 Dim P3 As POINTAPI
  1620.                 Dim CharPos As Long, CaretPos As Long
  1621.                 Dim SelStart As Long, SelEnd As Long
  1622.                 GetCursorPos P3
  1623.                 ScreenToClient TextBoxHandle, P3
  1624.                 CharPos = CIntToUInt(LoWord(SendMessage(TextBoxHandle, EM_CHARFROMPOS, 0, ByVal MakeDWord(P3.X, P3.Y))))
  1625.                 CaretPos = SendMessage(TextBoxHandle, EM_POSFROMCHAR, CharPos, ByVal 0&)
  1626.                 SendMessage TextBoxHandle, EM_GETSEL, VarPtr(SelStart), ByVal VarPtr(SelEnd)
  1627.                 TextBoxAutoDragInSel = CBool(CharPos >= SelStart And CharPos <= SelEnd And CaretPos > -1 And (SelEnd - SelStart) > 0)
  1628.                 If TextBoxAutoDragInSel = True Then
  1629.                     SetCursor LoadCursor(0, MousePointerID(vbArrow))
  1630.                     WindowProcControl = 1
  1631.                     Exit Function
  1632.                 End If
  1633.             Else
  1634.                 TextBoxAutoDragInSel = False
  1635.             End If
  1636.             If MousePointerID(PropMousePointer) <> 0 Then
  1637.                 SetCursor LoadCursor(0, MousePointerID(PropMousePointer))
  1638.                 WindowProcControl = 1
  1639.                 Exit Function
  1640.             ElseIf PropMousePointer = 99 Then
  1641.                 If Not PropMouseIcon Is Nothing Then
  1642.                     SetCursor PropMouseIcon.Handle
  1643.                     WindowProcControl = 1
  1644.                     Exit Function
  1645.                 End If
  1646.             End If
  1647.         End If
  1648.     Case WM_MOUSEACTIVATE
  1649.         Static InProc As Boolean
  1650.         If TextBoxTopDesignMode = False And GetFocus() <> TextBoxHandle Then
  1651.             If InProc = True Or LoWord(lParam) = HTBORDER Then WindowProcControl = MA_ACTIVATEANDEAT: Exit Function
  1652.             Select Case HiWord(lParam)
  1653.             Case WM_LBUTTONDOWN
  1654.                 On Error Resume Next
  1655.                 With UserControl
  1656.                     If .Extender.CausesValidation = True Then
  1657.                         InProc = True
  1658.                         Call ComCtlsTopParentValidateControls(Me)
  1659.                         InProc = False
  1660.                         If ERR.Number = 380 Then
  1661.                             WindowProcControl = MA_ACTIVATEANDEAT
  1662.                         Else
  1663.                             SetFocusAPI .hwnd
  1664.                             WindowProcControl = MA_NOACTIVATE
  1665.                         End If
  1666.                     Else
  1667.                         SetFocusAPI .hwnd
  1668.                         WindowProcControl = MA_NOACTIVATE
  1669.                     End If
  1670.                 End With
  1671.                 On Error GoTo 0
  1672.                 Exit Function
  1673.             End Select
  1674.         End If
  1675.     Case WM_KEYDOWN, WM_KEYUP, WM_SYSKEYDOWN, WM_SYSKEYUP
  1676.         Dim KeyCode As Integer
  1677.         KeyCode = wParam And &HFF&
  1678.         If wMsg = WM_KEYDOWN Or wMsg = WM_KEYUP Then
  1679.             If wMsg = WM_KEYDOWN Then
  1680.                 RaiseEvent KeyDown(KeyCode, GetShiftStateFromMsg())
  1681.             ElseIf wMsg = WM_KEYUP Then
  1682.                 RaiseEvent KeyUp(KeyCode, GetShiftStateFromMsg())
  1683.             End If
  1684.             If KeyCode = vbKeyInsert And PropAllowOverType = True Then
  1685.                 If wMsg = WM_KEYDOWN Then PropOverTypeMode = Not PropOverTypeMode
  1686.             End If
  1687.             TextBoxCharCodeCache = ComCtlsPeekCharCode(hwnd)
  1688.         ElseIf wMsg = WM_SYSKEYDOWN Then
  1689.             RaiseEvent KeyDown(KeyCode, GetShiftStateFromMsg())
  1690.         ElseIf wMsg = WM_SYSKEYUP Then
  1691.             RaiseEvent KeyUp(KeyCode, GetShiftStateFromMsg())
  1692.         End If
  1693.         wParam = KeyCode
  1694.     Case WM_CHAR
  1695.         Dim KeyChar As Integer
  1696.         If TextBoxCharCodeCache <> 0 Then
  1697.             KeyChar = CUIntToInt(TextBoxCharCodeCache And &HFFFF&)
  1698.             TextBoxCharCodeCache = 0
  1699.         Else
  1700.             KeyChar = CUIntToInt(wParam And &HFFFF&)
  1701.         End If
  1702.         RaiseEvent KeyPress(KeyChar)
  1703.         If (wParam And &HFFFF&) <> 0 And KeyChar = 0 Then
  1704.             Exit Function
  1705.         Else
  1706.             wParam = CIntToUInt(KeyChar)
  1707.         End If
  1708.         If PropAllowOverType = True And PropOverTypeMode = True Then
  1709.             If wParam >= 32 Then                                                ' 0 to 31 are non-printable
  1710.                 If Me.SelLength = 0 Then
  1711.                     Dim FirstCharPos As Long, Length As Long
  1712.                     FirstCharPos = SendMessage(TextBoxHandle, EM_LINEINDEX, -1, ByVal 0&)
  1713.                     If FirstCharPos > -1 Then
  1714.                         Length = SendMessage(TextBoxHandle, EM_LINELENGTH, FirstCharPos, ByVal 0&)
  1715.                         If Length > 0 Then
  1716.                             If Me.SelStart < (FirstCharPos + Length) Then
  1717.                                 Me.SelLength = 1
  1718.                                 Me.SelText = vbNullString
  1719.                             End If
  1720.                         End If
  1721.                     End If
  1722.                 End If
  1723.             End If
  1724.         End If
  1725.     Case WM_UNICHAR
  1726.         If wParam = UNICODE_NOCHAR Then WindowProcControl = 1 Else SendMessage hwnd, WM_CHAR, wParam, ByVal lParam
  1727.         Exit Function
  1728.     Case WM_INPUTLANGCHANGE
  1729.         Call ComCtlsSetIMEMode(hwnd, TextBoxIMCHandle, PropIMEMode)
  1730.     Case WM_IME_SETCONTEXT
  1731.         If wParam <> 0 Then Call ComCtlsSetIMEMode(hwnd, TextBoxIMCHandle, PropIMEMode)
  1732.     Case WM_IME_CHAR
  1733.         SendMessage hwnd, WM_CHAR, wParam, ByVal lParam
  1734.         Exit Function
  1735.     Case WM_LBUTTONDOWN
  1736.         If PropOLEDragMode = vbOLEDragAutomatic And TextBoxAutoDragInSel = True Then
  1737.             Dim P1 As POINTAPI
  1738.             P1.X = Get_X_lParam(lParam)
  1739.             P1.Y = Get_Y_lParam(lParam)
  1740.             ClientToScreen TextBoxHandle, P1
  1741.             If DragDetect(TextBoxHandle, CUIntToInt(P1.X And &HFFFF&), CUIntToInt(P1.Y And &HFFFF&)) <> 0 Then
  1742.                 TextBoxIsClick = False
  1743.                 Me.OLEDrag
  1744.             End If
  1745.             Exit Function
  1746.         End If
  1747.     Case WM_VSCROLL, WM_HSCROLL
  1748.         ' The notification codes EN_HSCROLL and EN_VSCROLL are not sent when clicking the scroll bar thumb itself.
  1749.         If LoWord(wParam) = SB_THUMBTRACK Then RaiseEvent Scroll
  1750.     Case WM_CONTEXTMENU
  1751.         If wParam = TextBoxHandle Then
  1752.             Dim P2 As POINTAPI, Handled As Boolean
  1753.             P2.X = Get_X_lParam(lParam)
  1754.             P2.Y = Get_Y_lParam(lParam)
  1755.             If P2.X > 0 And P2.Y > 0 Then
  1756.                 ScreenToClient TextBoxHandle, P2
  1757.                 RaiseEvent ContextMenu(Handled, UserControl.ScaleX(P2.X, vbPixels, vbContainerPosition), UserControl.ScaleY(P2.Y, vbPixels, vbContainerPosition))
  1758.             ElseIf P2.X = -1 And P2.Y = -1 Then
  1759.                 ' If the user types SHIFT + F10 then the X and Y coordinates are -1.
  1760.                 RaiseEvent ContextMenu(Handled, -1, -1)
  1761.             End If
  1762.             If Handled = True Then Exit Function
  1763.         End If
  1764.     Case WM_SETTEXT
  1765.         If TextBoxChangeFrozen = False And PropMultiLine = True Then
  1766.             ' According to MSDN:
  1767.             ' The EN_CHANGE notification code is not sent when the ES_MULTILINE style is used and the text is sent through WM_SETTEXT.
  1768.             Dim Buffer(0 To 1) As String
  1769.             Buffer(0) = String(SendMessage(hwnd, WM_GETTEXTLENGTH, 0, ByVal 0&), vbNullChar)
  1770.             SendMessage hwnd, WM_GETTEXT, Len(Buffer(0)) + 1, ByVal StrPtr(Buffer(0))
  1771.             If lParam <> 0 Then
  1772.                 Buffer(1) = String(lstrlen(lParam), vbNullChar)
  1773.                 CopyMemory ByVal StrPtr(Buffer(1)), ByVal lParam, LenB(Buffer(1))
  1774.             End If
  1775.             If Buffer(0) <> Buffer(1) Then
  1776.                 WindowProcControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
  1777.                 UserControl.PropertyChanged "Text"
  1778.                 On Error Resume Next
  1779.                 UserControl.Extender.DataChanged = True
  1780.                 On Error GoTo 0
  1781.                 RaiseEvent Change
  1782.                 Exit Function
  1783.             End If
  1784.         End If
  1785.     Case WM_PASTE
  1786.         If PropAllowOnlyNumbers = True Then
  1787.             If ComCtlsSupportLevel() <= 1 Then
  1788.                 Dim Text As String
  1789.                 Text = GetClipboardText()
  1790.                 If Not Text = vbNullString Then
  1791.                     Dim i As Long, InvalidText As Boolean
  1792.                     For i = 1 To Len(Text)
  1793.                         If InStr("0123456789", Mid$(Text, i, 1)) = 0 Then
  1794.                             InvalidText = True
  1795.                             Exit For
  1796.                         End If
  1797.                     Next i
  1798.                     If InvalidText = True Then
  1799.                         VBA.Interaction.Beep
  1800.                         Exit Function
  1801.                     End If
  1802.                 End If
  1803.             End If
  1804.         End If
  1805.     End Select
  1806.     WindowProcControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
  1807.     Select Case wMsg
  1808.     Case WM_LBUTTONDBLCLK, WM_MBUTTONDBLCLK, WM_RBUTTONDBLCLK
  1809.         RaiseEvent DblClick
  1810.     Case WM_LBUTTONDOWN, WM_MBUTTONDOWN, WM_RBUTTONDOWN, WM_MOUSEMOVE, WM_LBUTTONUP, WM_MBUTTONUP, WM_RBUTTONUP
  1811.         Dim X As Single
  1812.         Dim Y As Single
  1813.         X = UserControl.ScaleX(Get_X_lParam(lParam), vbPixels, vbTwips)
  1814.         Y = UserControl.ScaleY(Get_Y_lParam(lParam), vbPixels, vbTwips)
  1815.         Select Case wMsg
  1816.         Case WM_LBUTTONDOWN
  1817.             RaiseEvent MouseDown(vbLeftButton, GetShiftStateFromParam(wParam), X, Y)
  1818.             TextBoxIsClick = True
  1819.         Case WM_MBUTTONDOWN
  1820.             RaiseEvent MouseDown(vbMiddleButton, GetShiftStateFromParam(wParam), X, Y)
  1821.             TextBoxIsClick = True
  1822.         Case WM_RBUTTONDOWN
  1823.             RaiseEvent MouseDown(vbRightButton, GetShiftStateFromParam(wParam), X, Y)
  1824.             TextBoxIsClick = True
  1825.         Case WM_MOUSEMOVE
  1826.             If TextBoxMouseOver = False And PropMouseTrack = True Then
  1827.                 TextBoxMouseOver = True
  1828.                 RaiseEvent MouseEnter
  1829.                 Call ComCtlsRequestMouseLeave(hwnd)
  1830.             End If
  1831.             RaiseEvent MouseMove(GetMouseStateFromParam(wParam), GetShiftStateFromParam(wParam), X, Y)
  1832.         Case WM_LBUTTONUP, WM_MBUTTONUP, WM_RBUTTONUP
  1833.             Select Case wMsg
  1834.             Case WM_LBUTTONUP
  1835.                 RaiseEvent MouseUp(vbLeftButton, GetShiftStateFromParam(wParam), X, Y)
  1836.             Case WM_MBUTTONUP
  1837.                 RaiseEvent MouseUp(vbMiddleButton, GetShiftStateFromParam(wParam), X, Y)
  1838.             Case WM_RBUTTONUP
  1839.                 RaiseEvent MouseUp(vbRightButton, GetShiftStateFromParam(wParam), X, Y)
  1840.             End Select
  1841.             If TextBoxIsClick = True Then
  1842.                 TextBoxIsClick = False
  1843.                 If (X >= 0 And X <= UserControl.Width) And (Y >= 0 And Y <= UserControl.Height) Then RaiseEvent Click
  1844.             End If
  1845.         End Select
  1846.     Case WM_MOUSELEAVE
  1847.         If TextBoxMouseOver = True Then
  1848.             TextBoxMouseOver = False
  1849.             RaiseEvent MouseLeave
  1850.         End If
  1851.     End Select
  1852. End Function

  1853. Private Function WindowProcUserControl(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  1854.     Select Case wMsg
  1855.     Case WM_COMMAND
  1856.         Select Case HiWord(wParam)
  1857.         Case EN_CHANGE
  1858.             If TextBoxChangeFrozen = False Then
  1859.                 UserControl.PropertyChanged "Text"
  1860.                 On Error Resume Next
  1861.                 UserControl.Extender.DataChanged = True
  1862.                 On Error GoTo 0
  1863.                 RaiseEvent Change
  1864.             End If
  1865.         Case EN_MAXTEXT
  1866.             RaiseEvent MaxText
  1867.         Case EN_HSCROLL, EN_VSCROLL
  1868.             ' This notification code is also sent when a keyboard event causes a change in the view area.
  1869.             RaiseEvent Scroll
  1870.         End Select
  1871.     End Select
  1872.     WindowProcUserControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
  1873.     If wMsg = WM_SETFOCUS Then SetFocusAPI TextBoxHandle
  1874. End Function
复制代码
PPTextBoxWText.pag
  1. Option Explicit
  2. Private FreezeChanged As Boolean
  3. Private TextObject As Object
  4. Private WithEvents TextObjectEvents As TextBoxW

  5. Private Sub PropertyPage_Initialize()
  6.     Call ComCtlsShowAllUIStates(PropertyPage.hwnd)
  7.     On Error Resume Next
  8.     ERR.Raise 5
  9.     Set TextObject = PropertyPage.Controls.Add(ERR.Source & ".TextBoxW", "TextObject", Me)
  10.     On Error GoTo 0
  11.     If Not TextObject Is Nothing Then
  12.         Set TextObjectEvents = TextObject
  13.         TextObject.Left = 120
  14.         TextObject.Top = 120
  15.         TextObject.Width = 5655
  16.         TextObject.Height = 315
  17.         TextObject.Visible = True
  18.         TextObject.ZOrder vbBringToFront
  19.     End If
  20. End Sub

  21. Private Sub PropertyPage_ApplyChanges()
  22.     With PropertyPage.SelectedControls(0)
  23.         If Not TextObject Is Nothing Then .Text = TextObject.Text
  24.     End With
  25.     Call PropertyPage_SelectionChanged
  26. End Sub

  27. Private Sub PropertyPage_SelectionChanged()
  28.     FreezeChanged = True
  29.     With PropertyPage.SelectedControls(0)
  30.         If Not TextObject Is Nothing Then
  31.             If .MultiLine = True Then
  32.                 TextObject.Height = 3195
  33.                 TextObject.ScrollBars = vbBoth
  34.             Else
  35.                 TextObject.Height = 315
  36.                 TextObject.ScrollBars = vbSBNone
  37.             End If
  38.             TextObject.MultiLine = .MultiLine
  39.             TextObject.Text = .Text
  40.         End If
  41.     End With
  42.     FreezeChanged = False
  43. End Sub

  44. Private Sub PropertyPage_EditProperty(PropertyName As String)
  45.     If PropertyName = "Text" Then TextObject.SetFocus
  46. End Sub

  47. Private Sub TextObjectEvents_Change()
  48.     If FreezeChanged = True Then Exit Sub
  49.     PropertyPage.Changed = True
  50. End Sub

  51. Private Sub TextObjectEvents_KeyPress(KeyChar As Integer)
  52.     If KeyChar = vbKeyReturn Then KeyChar = AscW(vbLf)
  53. End Sub

复制代码

所需附件:
FrmAbout.frx (166.71 KB, 下载次数: 0)

评分

参与人数 1宅币 +10 收起 理由
0xAA55 + 10 屌!

查看全部评分

本版积分规则

QQ|申请友链||Archiver|手机版|小黑屋|技术宅的结界 ( 滇ICP备16008837号|网站地图

GMT+8, 2019-11-17 21:40 , Processed in 0.292601 second(s), 35 queries , Gzip On.

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

快速回复 返回顶部 返回列表