newdialog.cls

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

      .flags = FileFlags
      .hwndOwner = hwnd
      .hInstance = 0
      .lCustData = 0
      .lpfnHook = 0
      .lpstrDefExt = StrPtr(DefaultExt)
      .lpstrFile = FileName & String$(MAX_FILE - Len(FileName) + 1, vbNullChar)
      .lpstrFileTitle = FileTitle & Space$(256)
      .lpstrFilter = m_Filter
      .lpstrInitialDir = InitDir
      .lpstrTitle = DialogTitle
      .lpTemplateName = 0
      .lStructSize = Len(OpenFileName)
      .nFileExtension = 0
      .nFileOffset = 0
      .nFilterIndex = FilterIndex
      .nMaxCustFilter = 0
      .nMaxFile = MAX_FILE
      .nMaxFileTitle = MAX_FILE
   End With
   'and call the dialog box
   l = GetSaveFileName(OpenFileName)
   Select Case l
   Case 1
      With OpenFileName
         'now fill the data with result from dialog
         FileFlags = .flags
         DefaultExt = .lpstrDefExt
         FileName = NullTrim(.lpstrFile)
         FileTitle = NullTrim(.lpstrFileTitle)
         FileExt = .nFileExtension
         m_Filter = NullTrim(.lpstrFilter)
         InitDir = NullTrim(.lpstrInitialDir)
         FilterIndex = NullTrim(.nFilterIndex)
      End With
   Case 0
      'if user pressed cancel then generate error if CancelError is true (default is false)
      If CancelError Then Err.Raise 1001, "Run-time error", "Cancel was selected"
   Case Else
     ' Extended error
        m_ExtendedErr = CommDlgExtendedError()
        Err.Raise m_ExtendedErr
   End Select
End Sub

Public Sub ShowOpen()
   'Shows the Open File Dialog
   On Error Resume Next
   Dim ofn As TOPENFILENAME
   Dim l As Long
   With ofn
      'fill the data
      .flags = m_flags
      .hwndOwner = m_hWnd
      .hInstance = 0
      .lpfnHook = 0
      .lCustData = 0
      .lpstrDefExt = m_DefaultExt
      .lpstrFile = m_FileName & String$(MAX_FILE - Len(m_FileName) + 1, 0)
      .lpstrFileTitle = m_FileTitle & Space$(256)
      .lpstrFilter = m_Filter
      .lpstrInitialDir = m_InitDir
      .lpstrTitle = m_DialogTitle
      .lpTemplateName = 0
      .lStructSize = Len(ofn)
      .nFileExtension = 0
      .nFileOffset = 0
      .nFilterIndex = m_FilterIndex
      .nMaxCustFilter = 0
      .nMaxFile = MAX_FILE
      .nMaxFileTitle = MAX_FILE
      'apply hook if needed.
      'If m_fHook Then
      '   HookedDialog = Me
      '   .lpfnHook = HookAddress(AddressOf DialogHookFunction)
      '   .Flags = .Flags Or OFN_ENABLEHOOK Or OFN_EXPLORER
      'End If
   End With
   'call the dialog
   l = GetOpenFileName(ofn)
   ClearHookedDialog
   Select Case l
   Case 1
      With ofn
         'and fill data with results from dialog
         m_flags = .flags
         m_DefaultExt = .lpstrDefExt
         m_FileName = NullTrim(.lpstrFile)
         m_FileTitle = NullTrim(.lpstrFileTitle)
         m_FileExt = .nFileExtension
         m_Filter = NullTrim(.lpstrFilter)
         m_InitDir = NullTrim(.lpstrInitialDir)
         m_FilterIndex = NullTrim(.nFilterIndex)
      End With
   Case 0
      'if user pressed cancel then generate error if CancelError is true (default is false)
      If m_CancelError Then Err.Raise 1002, "Run-time error", "Cancel was selected"
   Case Else
      m_ExtendedErr = CommDlgExtendedError()
      Err.Raise m_ExtendedErr
   End Select
End Sub

Public Sub ShowFont()
   Dim PrinterDC As Long
   Dim l As Long
    ' Unwanted m_flags bits as we don't support them
    Const CF_FontNotSupported = CF_APPLY Or CF_ENABLEHOOK Or CF_ENABLETEMPLATE
    ' m_flags can get reference variable or constant with bit m_flags
    
    'Set the hdc for the printer if printerfonts are being used
    If m_flags And CF_PRINTERFONTS Then PrinterDC = Printer.hdc
    ' Must have some fonts
    If (m_flags And CF_PRINTERFONTS) = 0 Then m_flags = m_flags Or CF_SCREENFONTS
    
    'check to see if there was a color selected
    If m_FontColor > 0 Then m_flags = m_flags Or CF_EFFECTS
    
    'check to see if there were minimum or maximum sizes
    If m_FontMinSize > 0 Or m_FontMaxSize > 0 Then m_flags = m_flags Or CF_LIMITSIZE
    
    ' Put in required internal m_flags and remove unsupported
    m_flags = (m_flags Or CF_INITTOLOGFONTSTRUCT) And Not CF_FontNotSupported
    
    ' Initialize LOGFONT variable
    Dim LogFnt As LOGFONT
    Const PointsPerTwip = 1440 / 72
    LogFnt.lfHeight = -(m_Font.Size * (PointsPerTwip / Screen.TwipsPerPixelY))
    LogFnt.lfWeight = m_Font.Weight
    LogFnt.lfItalic = m_Font.Italic
    LogFnt.lfUnderline = m_Font.Underline
    LogFnt.lfStrikeOut = m_Font.Strikethrough
    ' Other fields zero
    StrToBytes LogFnt.lfFaceName, m_Font.Name

    ' Initialize TCHOOSEFONT variable
    Dim ChooseFnt As TCHOOSEFONT
    With ChooseFnt
      .lStructSize = Len(ChooseFnt)
      .hwndOwner = m_hWnd
      .hdc = PrinterDC
      .lpLogFont = VarPtr(LogFnt)
      .iPointSize = m_Font.Size * 10
      .flags = m_flags
      .rgbColors = Color
      .nSizeMin = m_FontMinSize
      .nSizeMax = m_FontMaxSize
    End With
    
    ' Call the dialog box
    l = ChooseFont(ChooseFnt)
    Select Case l
    Case 1
        ' Success
        m_flags = ChooseFnt.flags
        m_FontColor = ChooseFnt.rgbColors
        m_Font.Bold = ChooseFnt.nFontType And BOLD_FONTTYPE
        m_Font.Italic = LogFnt.lfItalic
        m_Font.Strikethrough = LogFnt.lfStrikeOut
        m_Font.Underline = LogFnt.lfUnderline
        m_Font.Weight = LogFnt.lfWeight
        m_Font.Size = ChooseFnt.iPointSize / 10
        m_Font.Name = StrConv(LogFnt.lfFaceName, vbUnicode)
    Case 0
      'canceled
      If m_CancelError Then Err.Raise 1001, "Run-time error", "Cancel was selected"
    Case Else
         ' Extended error
        m_ExtendedErr = CommDlgExtendedError()
        Err.Raise m_ExtendedErr
   End Select
        
End Sub

Sub ShowColor()
    Dim ChooseClr As TCHOOSECOLOR
    Dim afMask As Long
    Dim l As Long
    
    With ChooseClr
      .lStructSize = Len(ChooseClr)
    
      .hwndOwner = m_hWnd
      .rgbResult = m_Color
      
      ' Mask out unwanted bits
      afMask = CLng(Not (CC_ENABLEHOOK Or _
                       CC_ENABLETEMPLATE))
      .flags = afMask And m_flags
      .lpCustColors = VarPtr(alCustom(0))
    End With
   l = ChooseColor(ChooseClr)
    
    Select Case l
    Case 1
        ' Success
        m_Color = ChooseClr.rgbResult
    Case 0
        ' Cancelled
        If m_CancelError = True Then Err.Raise 1004, , "Choose Color Dialog was canceled"
        m_Color = -1
    Case Else
        ' Extended error
        m_ExtendedErr = CommDlgExtendedError()
        Err.Raise m_ExtendedErr
    End Select

End Sub

Public Function ShowPrinter() As Boolean
  'returns true if the dialog was used to assign a printer,
  'and/or print properties
  
  Dim pdlg As PrintDlg
  Dim lngResult As Long
  
  'set initial properties
  
  'window handle of owner
  pdlg.hwndOwner = m_hWnd
    
  'structure size
  pdlg.lStructSize = Len(pdlg)
  
  'call the api function
  lngResult& = PrintDlg(pdlg)
    
  If lngResult& <> 0 Then
    ShowPrinter = True
  Else
    ShowPrinter = False
    
  End If
  
  
End Function

Private Sub InitColors()
    Dim I As Integer
    ' Initialize with first 16 system interface colors
    For I = 0 To 15
        alCustom(I) = GetSysColor(I)
    Next
End Sub

' Property to read or modify custom colors (use to save colors in registry)
Public Property Get CustomColor(I As Integer) As Long
    If I >= 0 And I <= 15 Then
        CustomColor = alCustom(I)
    Else
        CustomColor = -1
    End If
End Property
Public Property Let Color(NewColor As Long)
   m_Color = NewColor
End Property
 
Public Property Get Color() As Long
    Color = m_Color
End Property
 
Public Property Let FontColor(NewColor As Long)
   m_FontColor = NewColor
End Property

Public Property Get FontColor() As Long
   FontColor = m_FontColor
End Property
Public Property Let FontMinSize(MinSize As Long)
   m_FontMinSize = MinSize
End Property

Public Property Let FontMaxSize(MaxSize As Long)
   m_FontMaxSize = MaxSize
End Property

Private Function HookAddress(Pointer As Long) As Long
    HookAddress = Pointer
End Function

Public Property Let InitDir(ByVal vData As String)
   ' Directory to open window in
   ' Default: "C:\"
   m_InitDir = vData
End Property
Public Property Get InitDir() As String
   InitDir = m_InitDir
End Property

Public Property Let FileFlags(ByVal vData As EOpenFile)
   ' Flags for the file dialogs
   m_flags = vData
End Property

Public Property Let flags(NewFlags As Long)
   'used for compatibility with the standard dialog control.  It is recommended that you use the
   'FileFlags, FontFlags and ColorFlags instead as they provide you with a list of the flags available.
   m_flags = NewFlags
End Property

Public Property Get flags() As Long
   flags = m_flags
End Property

Public Property Get FileFlags() As EOpenFile
   FileFlags = m_flags
End Property

Public Property Let FontFlags(ByVal vData As EChooseFont)
   'flags for the font dialog
   m_flags = vData
End Property

Public Property Get FontFlags() As EChooseFont
   FontFlags = m_flags
End Property

Public Property Let ColorFlags(ByVal vData As EChooseColor)
   'flages for the color dialog
   m_flags = vData
End Property

Public Property Get ColorFlags() As EChooseColor
   ColorFlags = m_flags
End Property

Public Property Let Filter(ByVal vData As String)
   ' Filters that the user can select in drowpdown combo
   ' Usage: Friendlyname1|*.ex1|Freindlyname2|*.ex2 etc.
   ' Default: "All Files (*.*)|*.*"
   Dim pipepos As String
   Do While InStr(vData, "|") > 0
      pipepos = InStr(vData, "|")
      If pipepos > 0 Then
         vData = Left$(vData, pipepos - 1) & vbNullChar & Right$(vData, Len(vData) - pipepos)
      End If
   Loop
   If Right$(vData, 2) <> vbNullChar & vbNullChar Then vData = vData & vbNullChar
   If Right$(vData, 2) <> vbNullChar & vbNullChar Then vData = vData & vbNullChar
   m_Filter = vData
End Property

Public Property Get Filter() As String
   Dim nullpos As String
   Dim tempfilter As String
   tempfilter = m_Filter
   Do While InStr(tempfilter, vbNullChar) > 0
      nullpos = InStr(tempfilter, vbNullChar)
      If nullpos > 0 Then
         tempfilter = Left$(tempfilter, nullpos - 1) & vbNullChar & Right$(tempfilter, Len(tempfilter) - nullpos)
      End If
   Loop
   If Right$(tempfilter, 1) = "|" Then tempfilter = Left$(tempfilter, Len(tempfilter) - 1)
   If Right$(tempfilter, 1) = "|" Then tempfilter = Left$(tempfilter, Len(tempfilter) - 1)
   Filter = tempfilter
End Property

Public Property Let FilterIndex(ByVal vData As Integer)
   ' Index of filter to select as default
   ' The first item is 1, second 2, etc.
   ' Default: 1
   m_FilterIndex = vData
End Property

Public Property Get FilterIndex() As Integer
   FilterIndex = m_FilterIndex
End Property

Public Property Let FileTitle(ByVal vData As String)
   ' The name of the file without path
   m_FileTitle = vData
End Property

Public Property Get FileTitle() As String
   FileTitle = m_FileTitle
End Property

Public Property Let FileName(ByVal vData As String)
' Name of the file, including path
   m_FileName = vData
End Property

Public Property Get FileName() As String
   FileName = m_FileName
End Property

Public Property Let DialogTitle(ByVal vData As String)
' The name of the dialog box
   m_DialogTitle = vData
End Property

Public Property Get DialogTitle() As String
   DialogTitle = m_DialogTitle
End Property

Public Property Let DefaultExt(ByVal vData As String)
   ' The default extension added if one is not specified in the name
   m_DefaultExt = vData
End Property

Public Property Get DefaultExt() As String
   DefaultExt = m_DefaultExt
End Property

Public Property Let CancelError(ByVal vData As Boolean)
   ' Raise an error if user clicks cancel
   ' Default: False
   m_CancelError = vData
End Property

Public Property Get CancelError() As Boolean
   CancelError = m_CancelError
End Property

Private Sub StrToBytes(ab() As Byte, s As String)
    If IsArrayEmpty(ab) Then
        ' Assign to empty array
        ab = StrConv(s, vbFromUnicode)
    Else
        Dim cab As Long
        ' Copy to existing array, padding or truncating if necessary
        cab = UBound(ab) - LBound(ab) + 1
        If Len(s) < cab Then s = s & String$(cab - Len(s), 0)
        CopyMemoryStr ab(LBound(ab)), s, cab
    End If
End Sub

Public Property Get FontBold() As Boolean
    'return object's FontBold property
    FontBold = m_Font.Bold
End Property

Public Property Let FontBold(ByVal vNewValue As Boolean)
    'Assign object's FontBold property
    m_Font.Bold = vNewValue
End Property

Public Property Get FontItalic() As Boolean
    'Return object's FontItalic property
    FontItalic = m_Font.Italic
End Property

Public Property Let FontItalic(ByVal vNewValue As Boolean)
    'Assign object's FontItalic property
    m_Font.Italic = vNewValue
End Property

Public Property Get FontName() As String
    'Return object's Fontname property
    FontName = m_Font.Name
End Property

Public Property Let FontName(ByVal vNewValue As String)
    'Assign object's FontName property
    m_Font.Name = vNewValue
End Property

Public Property Get FontSize() As Long
    'Return object's FontSize property
    FontSize = m_Font.Size
End Property

Public Property Let FontSize(ByVal vNewValue As Long)
    'Assign object's FontSize property
    m_Font.Size = vNewValue
End Property

Public Property Get Font() As StdFont
    Set Font = m_Font
End Property

Public Property Let Font(sFont As StdFont)
    Set m_Font = sFont
End Property

Private Sub Class_Initialize()
   'set up defaults
   CancelError = False
   DefaultExt = ""
   DialogTitle = ""
   FileName = ""
   FileTitle = ""
   Filter = "All Files|*.*"
   FilterIndex = 1
   InitDir = App.Path
   hwnd = 0
   InitColors
End Sub

Private Function IsArrayEmpty(va As Variant) As Boolean
    Dim v As Variant
    On Error Resume Next
    v = va(LBound(va))
    IsArrayEmpty = (Err <> 0)
End Function

Public Property Get Hook() As Boolean
       Hook = m_fHook
End Property

Public Property Let Hook(NewHook As Boolean)
       m_fHook = NewHook
End Property