NewDialog.cls
上传用户:bcdefg2008
上传日期:2013-02-28
资源大小:144k
文件大小:29k
源码类别:

Email服务器

开发平台:

Visual Basic

  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cmDlg"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
  15. Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
  16. Option Explicit
  17. Private Declare Function SendMessageStr Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
  18. 'Constants
  19. ' Messages:
  20. Private Const WM_DESTROY = &H2
  21. Private Const WM_NOTIFY = &H4E
  22. Private Const WM_NCDESTROY = &H82
  23. Private Const WM_GETDLGCODE = &H87
  24. Private Const WM_INITDIALOG = &H110
  25. Private Const WM_COMMAND = &H111
  26. ' Notification codes:
  27. Private Const H_MAX As Long = &HFFFF + 1
  28. Private Const CDN_FIRST = (H_MAX - 601)
  29. Private Const CDN_LAST = (H_MAX - 699)
  30. 'Notifications when Open or Save dialog status changes
  31. Private Const CDN_INITDONE = (CDN_FIRST - &H0)
  32. Private Const CDN_SELCHANGE = (CDN_FIRST - &H1)
  33. Private Const CDN_FOLDERCHANGE = (CDN_FIRST - &H2)
  34. Private Const CDN_SHAREVIOLATION = (CDN_FIRST - &H3)
  35. Private Const CDN_HELP = (CDN_FIRST - &H4)
  36. Private Const CDN_FILEOK = (CDN_FIRST - &H5)
  37. Private Const CDN_TYPECHANGE = (CDN_FIRST - &H6)
  38. Private Const CDN_INCLUDEITEM = (CDN_FIRST - &H7)
  39. Private Const LF_FACESIZE = 32
  40. Private Const MAX_FILE = 260
  41. Private Const SPI_GETWORKAREA = 48
  42. 'Enumerations
  43. Public Enum EOpenFile
  44.    OFN_READONLY = &H1
  45.    OFN_OVERWRITEPROMPT = &H2
  46.    OFN_HIDEREADONLY = &H4
  47.    OFN_NOCHANGEDIR = &H8
  48.    OFN_SHOWHELP = &H10
  49.    OFN_ENABLEHOOK = &H20
  50.    OFN_ENABLETEMPLATE = &H40
  51.    OFN_ENABLETEMPLATEHANDLE = &H80
  52.    OFN_NOVALIDATE = &H100
  53.    OFN_ALLOWMULTISELECT = &H200
  54.    OFN_EXTENSIONDIFFERENT = &H400
  55.    OFN_PATHMUSTEXIST = &H800
  56.    OFN_FILEMUSTEXIST = &H1000
  57.    OFN_CREATEPROMPT = &H2000
  58.    OFN_SHAREAWARE = &H4000
  59.    OFN_NOREADONLYRETURN = &H8000
  60.    OFN_NOTESTFILECREATE = &H10000
  61.    OFN_NONETWORKBUTTON = &H20000
  62.    OFN_NOLONGNAMES = &H40000
  63.    OFN_EXPLORER = &H80000
  64.    OFN_NODEREFERENCELINKS = &H100000
  65.    OFN_LONGNAMES = &H200000
  66.    OFN_ENABLEINCLUDENOTIFY = &H400000
  67.    OFN_ENABLESIZING = &H800000
  68.    OFN_NOREADONLYRETURN_C = &H8000&
  69. End Enum
  70. Public Enum EChooseColor
  71.    CC_RGBINIT = &H1
  72.    CC_FULLOPEN = &H2
  73.    CC_PREVENTFULLOPEN = &H4
  74.    CC_ColorShowHelp = &H8
  75.    CC_SOLIDCOLOR = &H80
  76.    CC_ANYCOLOR = &H100
  77.    CC_ENABLEHOOK = &H10
  78.    CC_ENABLETEMPLATE = &H20
  79.    CC_ENABLETEMPLATEHANDLE = &H40
  80. End Enum
  81. Public Enum EChooseFont
  82.    CF_SCREENFONTS = &H1
  83.    CF_PRINTERFONTS = &H2
  84.    CF_BOTH = &H3
  85.    CF_FONTSHOWHELP = &H4
  86.    CF_USESTYLE = &H80
  87.    CF_EFFECTS = &H100
  88.    CF_ANSIONLY = &H400
  89.    CF_NOVECTORFONTS = &H800
  90.    CF_NOOEMFONTS = &H800
  91.    CF_NOSIMULATIONS = &H1000
  92.    CF_LIMITSIZE = &H2000
  93.    CF_FIXEDPITCHONLY = &H4000
  94.    CF_WYSIWYG = &H8000
  95.    CF_FORCEFONTEXIST = &H10000
  96.    CF_SCALABLEONLY = &H20000
  97.    CF_TTONLY = &H40000
  98.    CF_NOFACESEL = &H80000
  99.    CF_NOSTYLESEL = &H100000
  100.    CF_NOSIZESEL = &H200000
  101.    CF_SELECTSCRIPT = &H400000
  102.    CF_NOSCRIPTSEL = &H800000
  103.    CF_NOVERTFONTS = &H1000000
  104.    CF_INITTOLOGFONTSTRUCT = &H40
  105.    CF_APPLY = &H200
  106.    CF_ENABLEHOOK = &H8
  107.    CF_ENABLETEMPLATE = &H10
  108.    CF_ENABLETEMPLATEHANDLE = &H20
  109. End Enum
  110. Public Enum EFontType
  111.     SIMULATED_FONTTYPE = &H8000
  112.     PRINTER_FONTTYPE = &H4000
  113.     SCREEN_FONTTYPE = &H2000
  114.     BOLD_FONTTYPE = &H100
  115.     ITALIC_FONTTYPE = &H200
  116.     REGULAR_FONTTYPE = &H400
  117. End Enum
  118. Public Enum EDialogError
  119.     CDERR_DIALOGFAILURE = &HFFFF
  120.     CDERR_GENERALCODES = &H0&
  121.     CDERR_STRUCTSIZE = &H1&
  122.     CDERR_INITIALIZATION = &H2&
  123.     CDERR_NOTEMPLATE = &H3&
  124.     CDERR_NOHINSTANCE = &H4&
  125.     CDERR_LOADSTRFAILURE = &H5&
  126.     CDERR_FINDRESFAILURE = &H6&
  127.     CDERR_LOADRESFAILURE = &H7&
  128.     CDERR_LOCKRESFAILURE = &H8&
  129.     CDERR_MEMALLOCFAILURE = &H9&
  130.     CDERR_MEMLOCKFAILURE = &HA&
  131.     CDERR_NOHOOK = &HB&
  132.     CDERR_REGISTERMSGFAIL = &HC&
  133.     CFERR_CHOOSEFONTCODES = &H2000&
  134.     CFERR_NOFONTS = &H2001&
  135.     CFERR_MAXLESSTHANMIN = &H2002&
  136.     FNERR_FILENAMECODES = &H3000&
  137.     FNERR_SUBCLASSFAILURE = &H3001&
  138.     FNERR_INVALIDFILENAME = &H3002&
  139.     FNERR_BUFFERTOOSMALL = &H3003&
  140.     CCERR_CHOOSECOLORCODES = &H5000&
  141. End Enum
  142. 'Structures (User Defined Types)
  143. Private Type TOPENFILENAME
  144.   lStructSize As Long
  145.   hwndOwner As Long
  146.   hInstance As Long
  147.   lpstrFilter As String
  148.   lpstrCustomFilter As String
  149.   nMaxCustFilter As Long
  150.   nFilterIndex As Long
  151.   lpstrFile As String
  152.   nMaxFile As Long
  153.   lpstrFileTitle As String
  154.   nMaxFileTitle As Long
  155.   lpstrInitialDir As String
  156.   lpstrTitle As String
  157.   flags As Long
  158.   nFileOffset As Integer
  159.   nFileExtension As Integer
  160.   lpstrDefExt As String
  161.   lCustData As Long
  162.   lpfnHook As Long
  163.   lpTemplateName As String
  164. End Type
  165. Private Type TCHOOSECOLOR
  166.     lStructSize As Long
  167.     hwndOwner As Long
  168.     hInstance As Long
  169.     rgbResult As Long
  170.     lpCustColors As Long
  171.     flags As Long
  172.     lCustData As Long
  173.     lpfnHook As Long
  174.     lpTemplateName As Long
  175. End Type
  176. Private Type TCHOOSEFONT
  177.     lStructSize As Long
  178.     hwndOwner As Long
  179.     hdc As Long
  180.     lpLogFont As Long
  181.     iPointSize As Long
  182.     flags As Long
  183.     rgbColors As Long
  184.     lCustData As Long
  185.     lpfnHook As Long
  186.     lpTemplateName As Long
  187.     hInstance As Long
  188.     lpszStyle As String
  189.     nFontType As Integer
  190.     iAlign As Integer
  191.     nSizeMin As Long
  192.     nSizeMax As Long
  193. End Type
  194. Private Type LOGFONT
  195.     lfHeight As Long
  196.     lfWidth As Long
  197.     lfEscapement As Long
  198.     lfOrientation As Long
  199.     lfWeight As Long
  200.     lfItalic As Byte
  201.     lfUnderline As Byte
  202.     lfStrikeOut As Byte
  203.     lfCharSet As Byte
  204.     lfOutPrecision As Byte
  205.     lfClipPrecision As Byte
  206.     lfQuality As Byte
  207.     lfPitchAndFamily As Byte
  208.     lfFaceName(LF_FACESIZE) As Byte
  209. End Type
  210. Private Type NMHDR
  211.     hWndFrom As Long
  212.     idFrom As Long
  213.     Code As Long
  214. End Type
  215. Private Type POINTL
  216.     X As Long
  217.     Y As Long
  218. End Type
  219. Private Type RECT
  220.     Left As Long
  221.     Top As Long
  222.     Right As Long
  223.     Bottom As Long
  224. End Type
  225. 'Declarations
  226. Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
  227. Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOPENFILENAME As TOPENFILENAME) As Long
  228. Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOPENFILENAME As TOPENFILENAME) As Long
  229. Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pCHOOSECOLOR As TCHOOSECOLOR) As Long
  230. Private Declare Function ChooseFont Lib "COMDLG32" Alias "ChooseFontA" (pCHOOSEFONT As TCHOOSEFONT) As Long
  231. Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
  232. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  233. Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
  234. Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
  235. 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
  236. Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
  237. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
  238. Private Declare Sub CopyMemoryStr Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, ByVal lpvSource As String, ByVal cbCopy As Long)
  239. Private Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PrintDlg) As Long
  240. 'local variables to hold property value(s)
  241. Private m_Font As New StdFont
  242. Private m_CancelError As Boolean
  243. Private m_DefaultExt As String
  244. Private m_DialogTitle As String
  245. Private m_FileName As String
  246. Private m_FileTitle As String
  247. Private m_FilterIndex As Integer
  248. Private m_Filter As String
  249. Private m_flags As Long
  250. Private m_InitDir As String
  251. Private m_MaxFileSize As Integer
  252. Private m_hWnd As Long
  253. Private m_FileExt As Integer
  254. Private m_fHook As Boolean
  255. Private m_FontMinSize As Long
  256. Private m_FontMaxSize As Long
  257. Private m_FontColor As Long
  258. Private m_Color As Long
  259. Private m_ExtendedErr As Long
  260. Private alCustom(0 To 15) As Long
  261. 'events
  262. Public Event InitDialog(ByVal hDlg As Long)
  263. Public Event FileChange(ByVal hDlg As Long)
  264. Public Event FolderChange(ByVal hDlg As Long)
  265. Public Event DialogOK(ByRef bCancel As Boolean)
  266. Public Event TypeChange(ByVal hDlg As Long)
  267. Public Event DialogClose()
  268. ' Messages which can be sent to the standard dialog elements
  269. Private Const WM_USER = &H400
  270. Private Const CDM_FIRST = (WM_USER + 100)
  271. Private Const CDM_LAST = (WM_USER + 200)
  272. Private Const CDM_GETSPEC = (CDM_FIRST + &H0)
  273. Private Const CDM_GETFILEPATH = (CDM_FIRST + &H1)
  274. Private Const CDM_GETFOLDERPATH = (CDM_FIRST + &H2)
  275. Private Const CDM_GETFOLDERIDLIST = (CDM_FIRST + &H3)
  276. Private Const CDM_SETCONTROLTEXT = (CDM_FIRST + &H4)
  277. Private Const CDM_HIDECONTROL = (CDM_FIRST + &H5)
  278. Private Const CDM_SETDEFEXT = (CDM_FIRST + &H6)
  279. ' IDs for standard common dialog controls
  280. Private Const ID_OPEN = &H1  'Open or Save button
  281. Private Const ID_CANCEL = &H2 'Cancel Button
  282. Private Const ID_HELP = &H40E 'Help Button
  283. Private Const ID_READONLY = &H410 'Read-only check box
  284. Private Const ID_FILETYPELABEL = &H441 'Files of type label
  285. Private Const ID_FILELABEL = &H442 'File name label
  286. Private Const ID_FOLDERLABEL = &H443 'Look in label
  287. Private Const ID_LIST = &H461 'Parent of file list
  288. Private Const ID_FORMAT = &H470 'File type combo box
  289. Private Const ID_FOLDER = &H471 'Folder combo box
  290. Private Const ID_FILETEXT = &H480 'File name text box
  291. 'used for page setup dialogs
  292. Private Type POINTAPI
  293.   X As Long
  294.   Y As Long
  295. End Type
  296. 'type for page setup dialogs
  297. Private Type PAGESETUPDLG
  298.   lStructSize As Long
  299.   hwndOwner As Long
  300.   hDevMode As Long
  301.   hDevNames As Long
  302.   flags As Long
  303.   ptPaperSize As POINTAPI
  304.   rtMinMargin As RECT
  305.   rtMargin As RECT
  306.   hInstance As Long
  307.   lCustData As Long
  308.   lpfnPageSetupHook As Long
  309.   lpfnPagePaintHook As Long
  310.   lpPageSetupTemplateName As String
  311.   hPageSetupTemplate As Long
  312. End Type
  313. 'printer dialog
  314. Private Type PrintDlg
  315.   lStructSize As Long
  316.   hwndOwner As Long
  317.   hDevMode As Long
  318.   hDevNames As Long
  319.   hdc As Long
  320.   flags As Long
  321.   nFromPage As Integer
  322.   nToPage As Integer
  323.   nMinPage As Integer
  324.   nMaxPage As Integer
  325.   nCopies As Integer
  326.   hInstance As Long
  327.   lCustData As Long
  328.   lpfnPrintHook As Long
  329.   lpfnSetupHook As Long
  330.   lpPrintTemplateName As String
  331.   lpSetupTemplateName As String
  332.   hPrintTemplate As Long
  333.   hSetupTemplate As Long
  334. End Type
  335. Private m_cHookedDialog As Long
  336. Property Let HookedDialog(ByRef cThis As cmDlg)
  337.     'Set cHookedDialog = cThis
  338.     m_cHookedDialog = ObjPtr(cThis)
  339. End Property
  340. Property Get HookedDialog() As cmDlg
  341.    Dim oThis As cmDlg
  342.    If (m_cHookedDialog <> 0) Then
  343.       ' Turn the pointer into an illegal, uncounted interface
  344.       CopyMemory oThis, m_cHookedDialog, 4
  345.       ' Do NOT hit the End button here! You will crash!
  346.       ' Assign to legal reference
  347.       Set HookedDialog = oThis
  348.       ' Still do NOT hit the End button here! You will still crash!
  349.       ' Destroy the illegal reference
  350.       CopyMemory oThis, 0&, 4
  351.    End If
  352. End Property
  353. Public Sub ClearHookedDialog()
  354.     m_cHookedDialog = 0
  355. End Sub
  356. Public Function DialogHookFunction(ByVal hDlg As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  357.    Dim ComDlg As cmDlg
  358.    Set ComDlg = HookedDialog
  359.    If Not (ComDlg Is Nothing) Then 'just to make sure the class was created properly...
  360.       DialogHookFunction = ComDlg.DialogHook(hDlg, msg, wParam, lParam)
  361.    End If
  362. End Function
  363. Public Property Get GetComDlgFileName(ByVal hDlg As Long) As String
  364.    Dim sBuf As String
  365.    Dim Pos As Long
  366.    Dim hwnd As Long
  367.    hwnd = GetParent(hDlg)
  368.    sBuf = String$(260, 0)
  369.    SendMessageStr hwnd, CDM_GETFILEPATH, 260, sBuf
  370.    GetComDlgFileName = NullTrim(sBuf)
  371. End Property
  372. Public Function NullTrim(s) As String
  373. 'convert a null terminated string to standard vb string, deleting any leading or trailing spaces
  374.      Dim I As Integer
  375.      I = InStr(s, vbNullChar)
  376.      If I > 0 Then s = Left$(s, I - 1)
  377.      s = Trim$(s)
  378.      NullTrim = s
  379. End Function
  380. Public Function DialogHook(ByVal hDlg As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long)
  381.    Dim NotifyMessage As NMHDR
  382.   
  383.    Select Case msg
  384.    Case WM_INITDIALOG
  385.       RaiseEvent InitDialog(hDlg)
  386.    Case WM_NOTIFY
  387.       CopyMemory NotifyMessage, ByVal lParam, Len(NotifyMessage)
  388.       Select Case NotifyMessage.Code
  389.       Case CDN_SELCHANGE
  390.          ' Changed selected file:
  391.          RaiseEvent FileChange(hDlg)
  392.       Case CDN_FOLDERCHANGE
  393.          ' Changed folder:
  394.          RaiseEvent FolderChange(hDlg)
  395.       Case CDN_FILEOK
  396.          ' Clicked OK:
  397.          SetWindowLong hDlg, 0&, 0&
  398.       Case CDN_HELP
  399.          ' Help clicked
  400.       Case CDN_TYPECHANGE
  401.          RaiseEvent TypeChange(hDlg)
  402.       Case CDN_INCLUDEITEM
  403.          ' Hmmm
  404.       End Select
  405.    Case WM_DESTROY
  406.       RaiseEvent DialogClose
  407.    End Select
  408. End Function
  409. Public Sub CenterDialog(ByVal hDlg As Long, Optional ByRef oCenterTo As Object)
  410.    Dim lhWnd As Long
  411.    Dim WindRect As RECT
  412.    Dim DialogRect As RECT
  413.    Dim tp As POINTL
  414.    Dim hWndCenterTo As Long
  415.    Dim lL As Long
  416.    Dim lT As Long
  417.    Dim lR As Long
  418.    lhWnd = GetParent(hDlg)
  419.    GetWindowRect lhWnd, DialogRect
  420.    On Error Resume Next
  421.    hWndCenterTo = oCenterTo.hwnd
  422.    If (Err.Number = 0) Then
  423.       GetWindowRect hWndCenterTo, WindRect
  424.    Else
  425.       ' Assume the screen object:
  426.       lR = SystemParametersInfo(SPI_GETWORKAREA, 0, WindRect, 0)
  427.       If (lR = 0) Then
  428.          ' Call failed - just use standard screen:
  429.          WindRect.Left = 0
  430.          WindRect.Top = 0
  431.          WindRect.Right = Screen.Width  Screen.TwipsPerPixelX
  432.          WindRect.Bottom = Screen.Height  Screen.TwipsPerPixelY
  433.       End If
  434.    End If
  435.    On Error GoTo 0
  436.    If (WindRect.Right > 0) And (WindRect.Bottom > 0) Then
  437.         lL = WindRect.Left + (((WindRect.Right - WindRect.Left) - (DialogRect.Right - DialogRect.Left))  2)
  438.         lT = WindRect.Top + (((WindRect.Bottom - WindRect.Top) - (DialogRect.Bottom - DialogRect.Top))  2)
  439.         MoveWindow lhWnd, lL, lT, (DialogRect.Right - DialogRect.Left), (DialogRect.Bottom - DialogRect.Top), 1
  440.     End If
  441. End Sub
  442. Public Property Let FileExt(ByVal vData As Integer)
  443.    m_FileExt = vData
  444. End Property
  445. Public Property Get FileExt() As Integer
  446.    FileExt = m_FileExt
  447. End Property
  448. Public Property Let hwnd(ByVal vData As Long)
  449.    m_hWnd = vData
  450. End Property
  451. Public Property Get hwnd() As Long
  452.    hwnd = m_hWnd
  453. End Property
  454. Public Sub ShowSave()
  455.    'Shows the Save File Dialog
  456.    Dim OpenFileName As TOPENFILENAME
  457.    Dim l As Long
  458.    With OpenFileName
  459.       'set the data
  460.       .flags = FileFlags
  461.       .hwndOwner = hwnd
  462.       .hInstance = 0
  463.       .lCustData = 0
  464.       .lpfnHook = 0
  465.       .lpstrDefExt = StrPtr(DefaultExt)
  466.       .lpstrFile = FileName & String$(MAX_FILE - Len(FileName) + 1, vbNullChar)
  467.       .lpstrFileTitle = FileTitle & Space$(256)
  468.       .lpstrFilter = m_Filter
  469.       .lpstrInitialDir = InitDir
  470.       .lpstrTitle = DialogTitle
  471.       .lpTemplateName = 0
  472.       .lStructSize = Len(OpenFileName)
  473.       .nFileExtension = 0
  474.       .nFileOffset = 0
  475.       .nFilterIndex = FilterIndex
  476.       .nMaxCustFilter = 0
  477.       .nMaxFile = MAX_FILE
  478.       .nMaxFileTitle = MAX_FILE
  479.    End With
  480.    'and call the dialog box
  481.    l = GetSaveFileName(OpenFileName)
  482.    Select Case l
  483.    Case 1
  484.       With OpenFileName
  485.          'now fill the data with result from dialog
  486.          FileFlags = .flags
  487.          DefaultExt = .lpstrDefExt
  488.          FileName = NullTrim(.lpstrFile)
  489.          FileTitle = NullTrim(.lpstrFileTitle)
  490.          FileExt = .nFileExtension
  491.          m_Filter = NullTrim(.lpstrFilter)
  492.          InitDir = NullTrim(.lpstrInitialDir)
  493.          FilterIndex = NullTrim(.nFilterIndex)
  494.       End With
  495.    Case 0
  496.       'if user pressed cancel then generate error if CancelError is true (default is false)
  497.       If CancelError Then Err.Raise 1001, "Run-time error", "Cancel was selected"
  498.    Case Else
  499.      ' Extended error
  500.         m_ExtendedErr = CommDlgExtendedError()
  501.         Err.Raise m_ExtendedErr
  502.    End Select
  503. End Sub
  504. Public Sub ShowOpen()
  505.    'Shows the Open File Dialog
  506.    On Error Resume Next
  507.    Dim ofn As TOPENFILENAME
  508.    Dim l As Long
  509.    With ofn
  510.       'fill the data
  511.       .flags = m_flags
  512.       .hwndOwner = m_hWnd
  513.       .hInstance = 0
  514.       .lpfnHook = 0
  515.       .lCustData = 0
  516.       .lpstrDefExt = m_DefaultExt
  517.       .lpstrFile = m_FileName & String$(MAX_FILE - Len(m_FileName) + 1, 0)
  518.       .lpstrFileTitle = m_FileTitle & Space$(256)
  519.       .lpstrFilter = m_Filter
  520.       .lpstrInitialDir = m_InitDir
  521.       .lpstrTitle = m_DialogTitle
  522.       .lpTemplateName = 0
  523.       .lStructSize = Len(ofn)
  524.       .nFileExtension = 0
  525.       .nFileOffset = 0
  526.       .nFilterIndex = m_FilterIndex
  527.       .nMaxCustFilter = 0
  528.       .nMaxFile = MAX_FILE
  529.       .nMaxFileTitle = MAX_FILE
  530.       'apply hook if needed.
  531.       'If m_fHook Then
  532.       '   HookedDialog = Me
  533.       '   .lpfnHook = HookAddress(AddressOf DialogHookFunction)
  534.       '   .Flags = .Flags Or OFN_ENABLEHOOK Or OFN_EXPLORER
  535.       'End If
  536.    End With
  537.    'call the dialog
  538.    l = GetOpenFileName(ofn)
  539.    ClearHookedDialog
  540.    Select Case l
  541.    Case 1
  542.       With ofn
  543.          'and fill data with results from dialog
  544.          m_flags = .flags
  545.          m_DefaultExt = .lpstrDefExt
  546.          m_FileName = NullTrim(.lpstrFile)
  547.          m_FileTitle = NullTrim(.lpstrFileTitle)
  548.          m_FileExt = .nFileExtension
  549.          m_Filter = NullTrim(.lpstrFilter)
  550.          m_InitDir = NullTrim(.lpstrInitialDir)
  551.          m_FilterIndex = NullTrim(.nFilterIndex)
  552.       End With
  553.    Case 0
  554.       'if user pressed cancel then generate error if CancelError is true (default is false)
  555.       If m_CancelError Then Err.Raise 1002, "Run-time error", "Cancel was selected"
  556.    Case Else
  557.       m_ExtendedErr = CommDlgExtendedError()
  558.       Err.Raise m_ExtendedErr
  559.    End Select
  560. End Sub
  561. Public Sub ShowFont()
  562.    Dim PrinterDC As Long
  563.    Dim l As Long
  564.     ' Unwanted m_flags bits as we don't support them
  565.     Const CF_FontNotSupported = CF_APPLY Or CF_ENABLEHOOK Or CF_ENABLETEMPLATE
  566.     ' m_flags can get reference variable or constant with bit m_flags
  567.     
  568.     'Set the hdc for the printer if printerfonts are being used
  569.     If m_flags And CF_PRINTERFONTS Then PrinterDC = Printer.hdc
  570.     ' Must have some fonts
  571.     If (m_flags And CF_PRINTERFONTS) = 0 Then m_flags = m_flags Or CF_SCREENFONTS
  572.     
  573.     'check to see if there was a color selected
  574.     If m_FontColor > 0 Then m_flags = m_flags Or CF_EFFECTS
  575.     
  576.     'check to see if there were minimum or maximum sizes
  577.     If m_FontMinSize > 0 Or m_FontMaxSize > 0 Then m_flags = m_flags Or CF_LIMITSIZE
  578.     
  579.     ' Put in required internal m_flags and remove unsupported
  580.     m_flags = (m_flags Or CF_INITTOLOGFONTSTRUCT) And Not CF_FontNotSupported
  581.     
  582.     ' Initialize LOGFONT variable
  583.     Dim LogFnt As LOGFONT
  584.     Const PointsPerTwip = 1440 / 72
  585.     LogFnt.lfHeight = -(m_Font.Size * (PointsPerTwip / Screen.TwipsPerPixelY))
  586.     LogFnt.lfWeight = m_Font.Weight
  587.     LogFnt.lfItalic = m_Font.Italic
  588.     LogFnt.lfUnderline = m_Font.Underline
  589.     LogFnt.lfStrikeOut = m_Font.Strikethrough
  590.     ' Other fields zero
  591.     StrToBytes LogFnt.lfFaceName, m_Font.Name
  592.     ' Initialize TCHOOSEFONT variable
  593.     Dim ChooseFnt As TCHOOSEFONT
  594.     With ChooseFnt
  595.       .lStructSize = Len(ChooseFnt)
  596.       .hwndOwner = m_hWnd
  597.       .hdc = PrinterDC
  598.       .lpLogFont = VarPtr(LogFnt)
  599.       .iPointSize = m_Font.Size * 10
  600.       .flags = m_flags
  601.       .rgbColors = Color
  602.       .nSizeMin = m_FontMinSize
  603.       .nSizeMax = m_FontMaxSize
  604.     End With
  605.     
  606.     ' Call the dialog box
  607.     l = ChooseFont(ChooseFnt)
  608.     Select Case l
  609.     Case 1
  610.         ' Success
  611.         m_flags = ChooseFnt.flags
  612.         m_FontColor = ChooseFnt.rgbColors
  613.         m_Font.Bold = ChooseFnt.nFontType And BOLD_FONTTYPE
  614.         m_Font.Italic = LogFnt.lfItalic
  615.         m_Font.Strikethrough = LogFnt.lfStrikeOut
  616.         m_Font.Underline = LogFnt.lfUnderline
  617.         m_Font.Weight = LogFnt.lfWeight
  618.         m_Font.Size = ChooseFnt.iPointSize / 10
  619.         m_Font.Name = StrConv(LogFnt.lfFaceName, vbUnicode)
  620.     Case 0
  621.       'canceled
  622.       If m_CancelError Then Err.Raise 1001, "Run-time error", "Cancel was selected"
  623.     Case Else
  624.          ' Extended error
  625.         m_ExtendedErr = CommDlgExtendedError()
  626.         Err.Raise m_ExtendedErr
  627.    End Select
  628.         
  629. End Sub
  630. Sub ShowColor()
  631.     Dim ChooseClr As TCHOOSECOLOR
  632.     Dim afMask As Long
  633.     Dim l As Long
  634.     
  635.     With ChooseClr
  636.       .lStructSize = Len(ChooseClr)
  637.     
  638.       .hwndOwner = m_hWnd
  639.       .rgbResult = m_Color
  640.       
  641.       ' Mask out unwanted bits
  642.       afMask = CLng(Not (CC_ENABLEHOOK Or _
  643.                        CC_ENABLETEMPLATE))
  644.       .flags = afMask And m_flags
  645.       .lpCustColors = VarPtr(alCustom(0))
  646.     End With
  647.    l = ChooseColor(ChooseClr)
  648.     
  649.     Select Case l
  650.     Case 1
  651.         ' Success
  652.         m_Color = ChooseClr.rgbResult
  653.     Case 0
  654.         ' Cancelled
  655.         If m_CancelError = True Then Err.Raise 1004, , "Choose Color Dialog was canceled"
  656.         m_Color = -1
  657.     Case Else
  658.         ' Extended error
  659.         m_ExtendedErr = CommDlgExtendedError()
  660.         Err.Raise m_ExtendedErr
  661.     End Select
  662. End Sub
  663. Public Function ShowPrinter() As Boolean
  664.   'returns true if the dialog was used to assign a printer,
  665.   'and/or print properties
  666.   
  667.   Dim pdlg As PrintDlg
  668.   Dim lngResult As Long
  669.   
  670.   'set initial properties
  671.   
  672.   'window handle of owner
  673.   pdlg.hwndOwner = m_hWnd
  674.     
  675.   'structure size
  676.   pdlg.lStructSize = Len(pdlg)
  677.   
  678.   'call the api function
  679.   lngResult& = PrintDlg(pdlg)
  680.     
  681.   If lngResult& <> 0 Then
  682.     ShowPrinter = True
  683.   Else
  684.     ShowPrinter = False
  685.     
  686.   End If
  687.   
  688.   
  689. End Function
  690. Private Sub InitColors()
  691.     Dim I As Integer
  692.     ' Initialize with first 16 system interface colors
  693.     For I = 0 To 15
  694.         alCustom(I) = GetSysColor(I)
  695.     Next
  696. End Sub
  697. ' Property to read or modify custom colors (use to save colors in registry)
  698. Public Property Get CustomColor(I As Integer) As Long
  699.     If I >= 0 And I <= 15 Then
  700.         CustomColor = alCustom(I)
  701.     Else
  702.         CustomColor = -1
  703.     End If
  704. End Property
  705. Public Property Let Color(NewColor As Long)
  706.    m_Color = NewColor
  707. End Property
  708.  
  709. Public Property Get Color() As Long
  710.     Color = m_Color
  711. End Property
  712.  
  713. Public Property Let FontColor(NewColor As Long)
  714.    m_FontColor = NewColor
  715. End Property
  716. Public Property Get FontColor() As Long
  717.    FontColor = m_FontColor
  718. End Property
  719. Public Property Let FontMinSize(MinSize As Long)
  720.    m_FontMinSize = MinSize
  721. End Property
  722. Public Property Let FontMaxSize(MaxSize As Long)
  723.    m_FontMaxSize = MaxSize
  724. End Property
  725. Private Function HookAddress(Pointer As Long) As Long
  726.     HookAddress = Pointer
  727. End Function
  728. Public Property Let InitDir(ByVal vData As String)
  729.    ' Directory to open window in
  730.    ' Default: "C:"
  731.    m_InitDir = vData
  732. End Property
  733. Public Property Get InitDir() As String
  734.    InitDir = m_InitDir
  735. End Property
  736. Public Property Let FileFlags(ByVal vData As EOpenFile)
  737.    ' Flags for the file dialogs
  738.    m_flags = vData
  739. End Property
  740. Public Property Let flags(NewFlags As Long)
  741.    'used for compatibility with the standard dialog control.  It is recommended that you use the
  742.    'FileFlags, FontFlags and ColorFlags instead as they provide you with a list of the flags available.
  743.    m_flags = NewFlags
  744. End Property
  745. Public Property Get flags() As Long
  746.    flags = m_flags
  747. End Property
  748. Public Property Get FileFlags() As EOpenFile
  749.    FileFlags = m_flags
  750. End Property
  751. Public Property Let FontFlags(ByVal vData As EChooseFont)
  752.    'flags for the font dialog
  753.    m_flags = vData
  754. End Property
  755. Public Property Get FontFlags() As EChooseFont
  756.    FontFlags = m_flags
  757. End Property
  758. Public Property Let ColorFlags(ByVal vData As EChooseColor)
  759.    'flages for the color dialog
  760.    m_flags = vData
  761. End Property
  762. Public Property Get ColorFlags() As EChooseColor
  763.    ColorFlags = m_flags
  764. End Property
  765. Public Property Let Filter(ByVal vData As String)
  766.    ' Filters that the user can select in drowpdown combo
  767.    ' Usage: Friendlyname1|*.ex1|Freindlyname2|*.ex2 etc.
  768.    ' Default: "All Files (*.*)|*.*"
  769.    Dim pipepos As String
  770.    Do While InStr(vData, "|") > 0
  771.       pipepos = InStr(vData, "|")
  772.       If pipepos > 0 Then
  773.          vData = Left$(vData, pipepos - 1) & vbNullChar & Right$(vData, Len(vData) - pipepos)
  774.       End If
  775.    Loop
  776.    If Right$(vData, 2) <> vbNullChar & vbNullChar Then vData = vData & vbNullChar
  777.    If Right$(vData, 2) <> vbNullChar & vbNullChar Then vData = vData & vbNullChar
  778.    m_Filter = vData
  779. End Property
  780. Public Property Get Filter() As String
  781.    Dim nullpos As String
  782.    Dim tempfilter As String
  783.    tempfilter = m_Filter
  784.    Do While InStr(tempfilter, vbNullChar) > 0
  785.       nullpos = InStr(tempfilter, vbNullChar)
  786.       If nullpos > 0 Then
  787.          tempfilter = Left$(tempfilter, nullpos - 1) & vbNullChar & Right$(tempfilter, Len(tempfilter) - nullpos)
  788.       End If
  789.    Loop
  790.    If Right$(tempfilter, 1) = "|" Then tempfilter = Left$(tempfilter, Len(tempfilter) - 1)
  791.    If Right$(tempfilter, 1) = "|" Then tempfilter = Left$(tempfilter, Len(tempfilter) - 1)
  792.    Filter = tempfilter
  793. End Property
  794. Public Property Let FilterIndex(ByVal vData As Integer)
  795.    ' Index of filter to select as default
  796.    ' The first item is 1, second 2, etc.
  797.    ' Default: 1
  798.    m_FilterIndex = vData
  799. End Property
  800. Public Property Get FilterIndex() As Integer
  801.    FilterIndex = m_FilterIndex
  802. End Property
  803. Public Property Let FileTitle(ByVal vData As String)
  804.    ' The name of the file without path
  805.    m_FileTitle = vData
  806. End Property
  807. Public Property Get FileTitle() As String
  808.    FileTitle = m_FileTitle
  809. End Property
  810. Public Property Let FileName(ByVal vData As String)
  811. ' Name of the file, including path
  812.    m_FileName = vData
  813. End Property
  814. Public Property Get FileName() As String
  815.    FileName = m_FileName
  816. End Property
  817. Public Property Let DialogTitle(ByVal vData As String)
  818. ' The name of the dialog box
  819.    m_DialogTitle = vData
  820. End Property
  821. Public Property Get DialogTitle() As String
  822.    DialogTitle = m_DialogTitle
  823. End Property
  824. Public Property Let DefaultExt(ByVal vData As String)
  825.    ' The default extension added if one is not specified in the name
  826.    m_DefaultExt = vData
  827. End Property
  828. Public Property Get DefaultExt() As String
  829.    DefaultExt = m_DefaultExt
  830. End Property
  831. Public Property Let CancelError(ByVal vData As Boolean)
  832.    ' Raise an error if user clicks cancel
  833.    ' Default: False
  834.    m_CancelError = vData
  835. End Property
  836. Public Property Get CancelError() As Boolean
  837.    CancelError = m_CancelError
  838. End Property
  839. Private Sub StrToBytes(ab() As Byte, s As String)
  840.     If IsArrayEmpty(ab) Then
  841.         ' Assign to empty array
  842.         ab = StrConv(s, vbFromUnicode)
  843.     Else
  844.         Dim cab As Long
  845.         ' Copy to existing array, padding or truncating if necessary
  846.         cab = UBound(ab) - LBound(ab) + 1
  847.         If Len(s) < cab Then s = s & String$(cab - Len(s), 0)
  848.         CopyMemoryStr ab(LBound(ab)), s, cab
  849.     End If
  850. End Sub
  851. Public Property Get FontBold() As Boolean
  852.     'return object's FontBold property
  853.     FontBold = m_Font.Bold
  854. End Property
  855. Public Property Let FontBold(ByVal vNewValue As Boolean)
  856.     'Assign object's FontBold property
  857.     m_Font.Bold = vNewValue
  858. End Property
  859. Public Property Get FontItalic() As Boolean
  860.     'Return object's FontItalic property
  861.     FontItalic = m_Font.Italic
  862. End Property
  863. Public Property Let FontItalic(ByVal vNewValue As Boolean)
  864.     'Assign object's FontItalic property
  865.     m_Font.Italic = vNewValue
  866. End Property
  867. Public Property Get FontName() As String
  868.     'Return object's Fontname property
  869.     FontName = m_Font.Name
  870. End Property
  871. Public Property Let FontName(ByVal vNewValue As String)
  872.     'Assign object's FontName property
  873.     m_Font.Name = vNewValue
  874. End Property
  875. Public Property Get FontSize() As Long
  876.     'Return object's FontSize property
  877.     FontSize = m_Font.Size
  878. End Property
  879. Public Property Let FontSize(ByVal vNewValue As Long)
  880.     'Assign object's FontSize property
  881.     m_Font.Size = vNewValue
  882. End Property
  883. Public Property Get Font() As StdFont
  884.     Set Font = m_Font
  885. End Property
  886. Public Property Let Font(sFont As StdFont)
  887.     Set m_Font = sFont
  888. End Property
  889. Private Sub Class_Initialize()
  890.    'set up defaults
  891.    CancelError = False
  892.    DefaultExt = ""
  893.    DialogTitle = ""
  894.    FileName = ""
  895.    FileTitle = ""
  896.    Filter = "All Files|*.*"
  897.    FilterIndex = 1
  898.    InitDir = App.Path
  899.    hwnd = 0
  900.    InitColors
  901. End Sub
  902. Private Function IsArrayEmpty(va As Variant) As Boolean
  903.     Dim v As Variant
  904.     On Error Resume Next
  905.     v = va(LBound(va))
  906.     IsArrayEmpty = (Err <> 0)
  907. End Function
  908. Public Property Get Hook() As Boolean
  909.        Hook = m_fHook
  910. End Property
  911. Public Property Let Hook(NewHook As Boolean)
  912.        m_fHook = NewHook
  913. End Property