newdialog.cls

简单、实用、特别。 有很多不足之处

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cmDlg"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"

Option Explicit

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


'Constants
' Messages:
Private Const WM_DESTROY = &H2
Private Const WM_NOTIFY = &H4E
Private Const WM_NCDESTROY = &H82
Private Const WM_GETDLGCODE = &H87
Private Const WM_INITDIALOG = &H110
Private Const WM_COMMAND = &H111

' Notification codes:
Private Const H_MAX As Long = &HFFFF + 1
Private Const CDN_FIRST = (H_MAX - 601)
Private Const CDN_LAST = (H_MAX - 699)

'Notifications when Open or Save dialog status changes
Private Const CDN_INITDONE = (CDN_FIRST - &H0)
Private Const CDN_SELCHANGE = (CDN_FIRST - &H1)
Private Const CDN_FOLDERCHANGE = (CDN_FIRST - &H2)
Private Const CDN_SHAREVIOLATION = (CDN_FIRST - &H3)
Private Const CDN_HELP = (CDN_FIRST - &H4)
Private Const CDN_FILEOK = (CDN_FIRST - &H5)
Private Const CDN_TYPECHANGE = (CDN_FIRST - &H6)
Private Const CDN_INCLUDEITEM = (CDN_FIRST - &H7)

Private Const LF_FACESIZE = 32
Private Const MAX_FILE = 260
Private Const SPI_GETWORKAREA = 48


'Enumerations
Public Enum EOpenFile
   OFN_READONLY = &H1
   OFN_OVERWRITEPROMPT = &H2
   OFN_HIDEREADONLY = &H4
   OFN_NOCHANGEDIR = &H8
   OFN_SHOWHELP = &H10
   OFN_ENABLEHOOK = &H20
   OFN_ENABLETEMPLATE = &H40
   OFN_ENABLETEMPLATEHANDLE = &H80
   OFN_NOVALIDATE = &H100
   OFN_ALLOWMULTISELECT = &H200
   OFN_EXTENSIONDIFFERENT = &H400
   OFN_PATHMUSTEXIST = &H800
   OFN_FILEMUSTEXIST = &H1000
   OFN_CREATEPROMPT = &H2000
   OFN_SHAREAWARE = &H4000
   OFN_NOREADONLYRETURN = &H8000
   OFN_NOTESTFILECREATE = &H10000
   OFN_NONETWORKBUTTON = &H20000
   OFN_NOLONGNAMES = &H40000
   OFN_EXPLORER = &H80000
   OFN_NODEREFERENCELINKS = &H100000
   OFN_LONGNAMES = &H200000
   OFN_ENABLEINCLUDENOTIFY = &H400000
   OFN_ENABLESIZING = &H800000
   OFN_NOREADONLYRETURN_C = &H8000&
End Enum

Public Enum EChooseColor
   CC_RGBINIT = &H1
   CC_FULLOPEN = &H2
   CC_PREVENTFULLOPEN = &H4
   CC_ColorShowHelp = &H8
   CC_SOLIDCOLOR = &H80
   CC_ANYCOLOR = &H100
   CC_ENABLEHOOK = &H10
   CC_ENABLETEMPLATE = &H20
   CC_ENABLETEMPLATEHANDLE = &H40
End Enum

Public Enum EChooseFont
   CF_SCREENFONTS = &H1
   CF_PRINTERFONTS = &H2
   CF_BOTH = &H3
   CF_FONTSHOWHELP = &H4
   CF_USESTYLE = &H80
   CF_EFFECTS = &H100
   CF_ANSIONLY = &H400
   CF_NOVECTORFONTS = &H800
   CF_NOOEMFONTS = &H800
   CF_NOSIMULATIONS = &H1000
   CF_LIMITSIZE = &H2000
   CF_FIXEDPITCHONLY = &H4000
   CF_WYSIWYG = &H8000
   CF_FORCEFONTEXIST = &H10000
   CF_SCALABLEONLY = &H20000
   CF_TTONLY = &H40000
   CF_NOFACESEL = &H80000
   CF_NOSTYLESEL = &H100000
   CF_NOSIZESEL = &H200000
   CF_SELECTSCRIPT = &H400000
   CF_NOSCRIPTSEL = &H800000
   CF_NOVERTFONTS = &H1000000
   CF_INITTOLOGFONTSTRUCT = &H40
   CF_APPLY = &H200
   CF_ENABLEHOOK = &H8
   CF_ENABLETEMPLATE = &H10
   CF_ENABLETEMPLATEHANDLE = &H20
End Enum

Public Enum EFontType
    SIMULATED_FONTTYPE = &H8000
    PRINTER_FONTTYPE = &H4000
    SCREEN_FONTTYPE = &H2000
    BOLD_FONTTYPE = &H100
    ITALIC_FONTTYPE = &H200
    REGULAR_FONTTYPE = &H400
End Enum

Public Enum EDialogError
    CDERR_DIALOGFAILURE = &HFFFF
    CDERR_GENERALCODES = &H0&
    CDERR_STRUCTSIZE = &H1&
    CDERR_INITIALIZATION = &H2&
    CDERR_NOTEMPLATE = &H3&
    CDERR_NOHINSTANCE = &H4&
    CDERR_LOADSTRFAILURE = &H5&
    CDERR_FINDRESFAILURE = &H6&
    CDERR_LOADRESFAILURE = &H7&
    CDERR_LOCKRESFAILURE = &H8&
    CDERR_MEMALLOCFAILURE = &H9&
    CDERR_MEMLOCKFAILURE = &HA&
    CDERR_NOHOOK = &HB&
    CDERR_REGISTERMSGFAIL = &HC&
    CFERR_CHOOSEFONTCODES = &H2000&
    CFERR_NOFONTS = &H2001&
    CFERR_MAXLESSTHANMIN = &H2002&
    FNERR_FILENAMECODES = &H3000&
    FNERR_SUBCLASSFAILURE = &H3001&
    FNERR_INVALIDFILENAME = &H3002&
    FNERR_BUFFERTOOSMALL = &H3003&
    CCERR_CHOOSECOLORCODES = &H5000&
End Enum

'Structures (User Defined Types)
Private Type TOPENFILENAME
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  flags As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type

Private Type TCHOOSECOLOR
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As Long
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As Long
End Type

Private Type TCHOOSEFONT
    lStructSize As Long
    hwndOwner As Long
    hdc As Long
    lpLogFont As Long
    iPointSize As Long
    flags As Long
    rgbColors As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As Long
    hInstance As Long
    lpszStyle As String
    nFontType As Integer
    iAlign As Integer
    nSizeMin As Long
    nSizeMax As Long
End Type

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE) As Byte
End Type

Private Type NMHDR
    hWndFrom As Long
    idFrom As Long
    Code As Long
End Type

Private Type POINTL
    X As Long
    Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

'Declarations
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOPENFILENAME As TOPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOPENFILENAME As TOPENFILENAME) As Long
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pCHOOSECOLOR As TCHOOSECOLOR) As Long
Private Declare Function ChooseFont Lib "COMDLG32" Alias "ChooseFontA" (pCHOOSEFONT As TCHOOSEFONT) As Long
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Sub CopyMemoryStr Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, ByVal lpvSource As String, ByVal cbCopy As Long)
Private Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PrintDlg) As Long

'local variables to hold property value(s)
Private m_Font As New StdFont
Private m_CancelError As Boolean
Private m_DefaultExt As String
Private m_DialogTitle As String
Private m_FileName As String
Private m_FileTitle As String
Private m_FilterIndex As Integer
Private m_Filter As String
Private m_flags As Long
Private m_InitDir As String
Private m_MaxFileSize As Integer
Private m_hWnd As Long
Private m_FileExt As Integer
Private m_fHook As Boolean
Private m_FontMinSize As Long
Private m_FontMaxSize As Long
Private m_FontColor As Long
Private m_Color As Long
Private m_ExtendedErr As Long
Private alCustom(0 To 15) As Long

'events
Public Event InitDialog(ByVal hDlg As Long)
Public Event FileChange(ByVal hDlg As Long)
Public Event FolderChange(ByVal hDlg As Long)
Public Event DialogOK(ByRef bCancel As Boolean)
Public Event TypeChange(ByVal hDlg As Long)
Public Event DialogClose()

' Messages which can be sent to the standard dialog elements
Private Const WM_USER = &H400
Private Const CDM_FIRST = (WM_USER + 100)
Private Const CDM_LAST = (WM_USER + 200)
Private Const CDM_GETSPEC = (CDM_FIRST + &H0)
Private Const CDM_GETFILEPATH = (CDM_FIRST + &H1)
Private Const CDM_GETFOLDERPATH = (CDM_FIRST + &H2)
Private Const CDM_GETFOLDERIDLIST = (CDM_FIRST + &H3)
Private Const CDM_SETCONTROLTEXT = (CDM_FIRST + &H4)
Private Const CDM_HIDECONTROL = (CDM_FIRST + &H5)
Private Const CDM_SETDEFEXT = (CDM_FIRST + &H6)

' IDs for standard common dialog controls
Private Const ID_OPEN = &H1  'Open or Save button
Private Const ID_CANCEL = &H2 'Cancel Button
Private Const ID_HELP = &H40E 'Help Button
Private Const ID_READONLY = &H410 'Read-only check box
Private Const ID_FILETYPELABEL = &H441 'Files of type label
Private Const ID_FILELABEL = &H442 'File name label
Private Const ID_FOLDERLABEL = &H443 'Look in label
Private Const ID_LIST = &H461 'Parent of file list
Private Const ID_FORMAT = &H470 'File type combo box
Private Const ID_FOLDER = &H471 'Folder combo box
Private Const ID_FILETEXT = &H480 'File name text box

'used for page setup dialogs
Private Type POINTAPI
  X As Long
  Y As Long
End Type


'type for page setup dialogs
Private Type PAGESETUPDLG
  lStructSize As Long
  hwndOwner As Long
  hDevMode As Long
  hDevNames As Long
  flags As Long
  ptPaperSize As POINTAPI
  rtMinMargin As RECT
  rtMargin As RECT
  hInstance As Long
  lCustData As Long
  lpfnPageSetupHook As Long
  lpfnPagePaintHook As Long
  lpPageSetupTemplateName As String
  hPageSetupTemplate As Long
End Type

'printer dialog
Private Type PrintDlg
  lStructSize As Long
  hwndOwner As Long
  hDevMode As Long
  hDevNames As Long
  hdc As Long
  flags As Long
  nFromPage As Integer
  nToPage As Integer
  nMinPage As Integer
  nMaxPage As Integer
  nCopies As Integer
  hInstance As Long
  lCustData As Long
  lpfnPrintHook As Long
  lpfnSetupHook As Long
  lpPrintTemplateName As String
  lpSetupTemplateName As String
  hPrintTemplate As Long
  hSetupTemplate As Long
End Type


Private m_cHookedDialog As Long

Property Let HookedDialog(ByRef cThis As cmDlg)
    'Set cHookedDialog = cThis
    m_cHookedDialog = ObjPtr(cThis)
End Property

Property Get HookedDialog() As cmDlg
   Dim oThis As cmDlg
   If (m_cHookedDialog <> 0) Then
      ' Turn the pointer into an illegal, uncounted interface
      CopyMemory oThis, m_cHookedDialog, 4
      ' Do NOT hit the End button here! You will crash!
      ' Assign to legal reference
      Set HookedDialog = oThis
      ' Still do NOT hit the End button here! You will still crash!
      ' Destroy the illegal reference
      CopyMemory oThis, 0&, 4
   End If
End Property
Public Sub ClearHookedDialog()
    m_cHookedDialog = 0
End Sub

Public Function DialogHookFunction(ByVal hDlg As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   Dim ComDlg As cmDlg
   Set ComDlg = HookedDialog
   If Not (ComDlg Is Nothing) Then 'just to make sure the class was created properly...
      DialogHookFunction = ComDlg.DialogHook(hDlg, msg, wParam, lParam)
   End If
End Function

Public Property Get GetComDlgFileName(ByVal hDlg As Long) As String
   Dim sBuf As String
   Dim Pos As Long
   Dim hwnd As Long
   hwnd = GetParent(hDlg)
   sBuf = String$(260, 0)
   SendMessageStr hwnd, CDM_GETFILEPATH, 260, sBuf
   GetComDlgFileName = NullTrim(sBuf)
End Property

Public Function NullTrim(s) As String
'convert a null terminated string to standard vb string, deleting any leading or trailing spaces
     Dim I As Integer
     I = InStr(s, vbNullChar)
     If I > 0 Then s = Left$(s, I - 1)
     s = Trim$(s)
     NullTrim = s
End Function



Public Function DialogHook(ByVal hDlg As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long)
   Dim NotifyMessage As NMHDR
  
   Select Case msg
   Case WM_INITDIALOG
      RaiseEvent InitDialog(hDlg)
   Case WM_NOTIFY
      CopyMemory NotifyMessage, ByVal lParam, Len(NotifyMessage)
      Select Case NotifyMessage.Code
      Case CDN_SELCHANGE
         ' Changed selected file:
         RaiseEvent FileChange(hDlg)
      Case CDN_FOLDERCHANGE
         ' Changed folder:
         RaiseEvent FolderChange(hDlg)
      Case CDN_FILEOK
         ' Clicked OK:
         SetWindowLong hDlg, 0&, 0&
      Case CDN_HELP
         ' Help clicked
      Case CDN_TYPECHANGE
         RaiseEvent TypeChange(hDlg)
      Case CDN_INCLUDEITEM
         ' Hmmm
      End Select
   Case WM_DESTROY
      RaiseEvent DialogClose
   End Select

End Function

Public Sub CenterDialog(ByVal hDlg As Long, Optional ByRef oCenterTo As Object)
   Dim lhWnd As Long
   Dim WindRect As RECT
   Dim DialogRect As RECT
   Dim tp As POINTL
   Dim hWndCenterTo As Long
   Dim lL As Long
   Dim lT As Long
   Dim lR As Long

   lhWnd = GetParent(hDlg)
   GetWindowRect lhWnd, DialogRect
   On Error Resume Next
   hWndCenterTo = oCenterTo.hwnd
   If (Err.Number = 0) Then
      GetWindowRect hWndCenterTo, WindRect
   Else
      ' Assume the screen object:
      lR = SystemParametersInfo(SPI_GETWORKAREA, 0, WindRect, 0)
      If (lR = 0) Then
         ' Call failed - just use standard screen:
         WindRect.Left = 0
         WindRect.Top = 0
         WindRect.Right = Screen.Width \ Screen.TwipsPerPixelX
         WindRect.Bottom = Screen.Height \ Screen.TwipsPerPixelY
      End If
   End If
   On Error GoTo 0
   If (WindRect.Right > 0) And (WindRect.Bottom > 0) Then
        lL = WindRect.Left + (((WindRect.Right - WindRect.Left) - (DialogRect.Right - DialogRect.Left)) \ 2)
        lT = WindRect.Top + (((WindRect.Bottom - WindRect.Top) - (DialogRect.Bottom - DialogRect.Top)) \ 2)
        MoveWindow lhWnd, lL, lT, (DialogRect.Right - DialogRect.Left), (DialogRect.Bottom - DialogRect.Top), 1
    End If
End Sub

Public Property Let FileExt(ByVal vData As Integer)
   m_FileExt = vData
End Property

Public Property Get FileExt() As Integer
   FileExt = m_FileExt
End Property

Public Property Let hwnd(ByVal vData As Long)
   m_hWnd = vData
End Property

Public Property Get hwnd() As Long
   hwnd = m_hWnd
End Property

Public Sub ShowSave()
   'Shows the Save File Dialog
   Dim OpenFileName As TOPENFILENAME
   Dim l As Long
   With OpenFileName
      'set the data