ccommondialog.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 = "cCommonDialog"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' ==========================================================================
' Class:    cCommonDialog
' Filename: cCommonDialog.cls
' Author:   Steve McMahon
' Date:     24 May 1998
'
' A wrapper around GCommonDialog to make it look more
' like the standard common dialog control.
' ==========================================================================

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, arguments As Long) As Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_GETWORKAREA = 48&

' Properties to emulate the CommonDialog control:
Private m_bCancelError As Boolean
Private m_sFilter As String
Private m_lFilterIndex As Long
Private m_sFileName As String
Private m_oColor As OLE_COLOR
Private m_lCopies As Long
Private m_lFlags As Long
Private m_sDialogTitle As String
Private m_sDefaultExt As String
Private m_font As New StdFont
Private m_oFontColor As OLE_COLOR
Private m_lFromPage As Long
Private m_lhWnd As Long
Private m_eHelpCommand As EShowHelpCommands
Private m_sHelpContext As String
Private m_sHelpFile As String
Private m_sHelpKey As String
Private m_sInitDir As String
Private m_lMax As Long
Private m_lMaxFileSize As Long
Private m_lMin As Long
Private m_objObject As Object
Private m_iPrinterDefault As Integer
Private m_lToPage As Long
Private m_sFileTitle As String
Private m_hDC As Long
Private m_bHookDialog As Boolean
Private mCommonDialog As New GCommonDialog

'API function inside ShowHelp method
Private Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hWnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long
' WinHelp Commands:
Public Enum EShowHelpCommands
    HELP_COMMAND = &H102&
    HELP_CONTENTS = &H3&
    HELP_CONTEXT = &H1          '  Display topic in ulTopic
    HELP_CONTEXTPOPUP = &H8&
    HELP_FORCEFILE = &H9&
    HELP_HELPONHELP = &H4       '  Display help on using help
    HELP_INDEX = &H3            '  Display index
    HELP_KEY = &H101            '  Display topic for keyword in offabData
    HELP_MULTIKEY = &H201&
    HELP_PARTIALKEY = &H105&
    HELP_QUIT = &H2             '  Terminate help
    HELP_SETCONTENTS = &H5&
    HELP_SETINDEX = &H5         '  Set current Index for multi index help
    HELP_SETWINPOS = &H203&
        
    HELP_FINDER = &HB           ' Win95 version of HELP_CONTENTS
End Enum
Private Type HELPWININFO
    wStructSize As Long
    x As Long
    y As Long
    dx As Long
    dy As Long
    wMax As Long
    rgchMember As String * 2
End Type
Public Enum EShowHelpWindowPos
    SW_HIDE = 0
    SW_MAXIMIZE = 3
    SW_MINIMIZE = 6
    SW_SHOW = 5
    SW_SHOWMAXIMIZED = 3
    SW_SHOWMINIMIZED = 2
    SW_SHOWMINNOACTIVE = 7
    SW_SHOWNA = 8
    SW_SHOWNOACTIVATE = 4
    SW_SHOWNORMAL = 1
End Enum
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) 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 ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private m_bFileDialog As Boolean

' For template support
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private m_lhInstance As Long
Private m_lTemplateName As Long
Private m_bMakeTBarFlat As Boolean

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()
Public Event WMCommand(ByVal hDlg As Long, wParam As Long, lParam As Long)

Public Sub WMCommand(ByVal hDlg As Long, wParam As Long, lParam As Long)
    RaiseEvent WMCommand(hDlg, wParam, lParam)
End Sub

Public Sub ParseMultiFileName( _
      ByRef sDir As String, _
      ByRef sFiles() As String, _
      ByRef iFileCount As Long _
   )
Dim iPos As Long
Dim iNextPos As Long
Dim sAllFiles As String
Dim i As Long

   iPos = InStr(m_sFileName, vbNullChar & vbNullChar)
   If iPos <> 0 Then
      ' multi names
      sAllFiles = Left$(m_sFileName, iPos - 1)
      iPos = 1
      iNextPos = InStr(sAllFiles, vbNullChar)
      Do While iNextPos <> 0
         If (sDir = "") Then
            sDir = Mid$(sAllFiles, iPos, iNextPos - iPos)
         Else
            iFileCount = iFileCount + 1
            ReDim Preserve sFiles(1 To iFileCount) As String
            sFiles(iFileCount) = Mid$(sAllFiles, iPos, iNextPos - iPos)
         End If
         iPos = iNextPos + 1
         iNextPos = InStr(iPos, sAllFiles, vbNullChar)
      Loop
      iFileCount = iFileCount + 1
      ReDim Preserve sFiles(1 To iFileCount) As String
      sFiles(iFileCount) = Mid$(sAllFiles, iPos)
   Else
      ' single file
      iFileCount = 1
      ReDim sFiles(1 To 1) As String
      For i = Len(m_sFileName) To 1 Step -1
         If Mid$(m_sFileName, i, 1) = "\" Then
            If (i > 1) Then
               sDir = Left$(m_sFileName, i - 1)
               sFiles(1) = Mid$(m_sFileName, i + 1)
            Else
               sDir = ""
               sFiles(1) = m_sFileName
            End If
            Exit Sub
         End If
      Next i
      sDir = ""
      sFiles(1) = m_sFileName
   End If
End Sub

Public Sub DialogClose()
    RaiseEvent DialogClose
End Sub

Public Function TypeChange(ByVal hDlg As Long) As Long
    RaiseEvent TypeChange(hDlg)
End Function

Public Function InitDialog(ByVal hDlg As Long) As Long
   RaiseEvent InitDialog(hDlg)
End Function
Public Function FileChange(ByVal hDlg As Long) As Long
   RaiseEvent FileChange(hDlg)
End Function
Public Function FolderChange(ByVal hDlg As Long) As Long
   RaiseEvent FolderChange(hDlg)
End Function
Public Function ConfirmOK() As Boolean
Dim bCancel As Boolean
    bCancel = False
    RaiseEvent DialogOK(bCancel)
    If (bCancel) Then
        ConfirmOK = False
    Else
        ConfirmOK = True
    End If
End Function

Public Sub CentreDialog(ByVal hDlg As Long, ByRef oCentreTo As Object)
Dim lHwnd As Long
Dim tWR As RECT, tDR As RECT
Dim tp As POINTAPI
Dim lHwndCentreTo As Long
Dim lL As Long
Dim lT As Long
Dim lR As Long

    ' If we're showing a file dialog, then the rectangle is the
    ' parent of the dialog itself:
    If (m_bFileDialog) Then
        lHwnd = GetParent(hDlg)
    Else
        lHwnd = hDlg
    End If
    GetWindowRect lHwnd, tDR
    ' Debug.Print tDR.Right - tDR.Left, tDR.Bottom - tDR.Top
    
    On Error Resume Next
    lHwndCentreTo = oCentreTo.hWnd
    If (Err.Number = 0) Then
        GetWindowRect lHwndCentreTo, tWR
    Else
      ' Assume the screen object:
      lR = SystemParametersInfo(SPI_GETWORKAREA, 0, tWR, 0)
      If (lR = 0) Then
         ' Call failed - just use standard screen:
         tWR.Left = 0
         tWR.Top = 0
         tWR.Right = Screen.Width \ Screen.TwipsPerPixelX
         tWR.Bottom = Screen.Height \ Screen.TwipsPerPixelY
      End If
    End If
    On Error GoTo 0
    If (tWR.Right > 0) And (tWR.Bottom > 0) Then
        lL = tWR.Left + (((tWR.Right - tWR.Left) - (tDR.Right - tDR.Left)) \ 2)
        lT = tWR.Top + (((tWR.Bottom - tWR.Top) - (tDR.Bottom - tDR.Top)) \ 2)
        ' Debug.Print tDR.Right - tDR.Left, tDR.Bottom - tDR.Top
        MoveWindow lHwnd, lL, lT, (tDR.Right - tDR.Left), (tDR.Bottom - tDR.Top), 1
    End If
End Sub
Public Sub GetDialogSize( _
        ByVal hDlg As Long, _
        ByRef lL As Long, _
        ByRef lT As Long, _
        ByRef lW As Long, _
        ByRef lH As Long _
    )
Dim lHwnd As Long
Dim tDR As RECT
    If (m_bFileDialog) Then
        lHwnd = GetParent(hDlg)
    Else
        lHwnd = hDlg
    End If
    GetWindowRect lHwnd, tDR
    lL = tDR.Left
    lT = tDR.Top
    lW = tDR.Right - tDR.Left
    lH = tDR.Bottom - tDR.Top
End Sub


Public Sub SetHelpPosition(x As Long, y As Long, dx As Long, dy As Long, eWindowType As EShowHelpWindowPos)
Dim tW As HELPWININFO
Dim lptr As Long

    With tW
        .x = x
        .y = y
        .dx = dx
        .dy = dy
        .wMax = eWindowType
        .wStructSize = Len(tW)
    End With
    Dim cM As New cMemory
    cM.AllocateMemory tW.wStructSize
    lptr = cM.Pointer
    CopyMemory ByVal lptr, tW, tW.wStructSize
    WinHelp m_lhWnd, m_sHelpFile, HELP_SETWINPOS, lptr
    cM.FreeMemory
    
End Sub

Public Property Get CancelError() As Boolean
    CancelError = m_bCancelError
End Property
Public Property Let CancelError(ByVal bCancelError As Boolean)
    m_bCancelError = bCancelError
End Property
Public Property Get Filename() As String
    'return object's FileName property
    Filename = m_sFileName
End Property
Public Property Let Filename(ByVal sFileName As String)
    'assign object's FileName property
    m_sFileName = sFileName
End Property
Public Property Get Filter() As String
    'return object's Filter property
    Filter = m_sFilter
End Property
Public Property Let Filter(ByVal sFilter As String)
    'assign object's Filter property
    m_sFilter = sFilter
End Property
Public Property Get FilterIndex() As Long
    'return object's FilterIndex property
    FilterIndex = m_lFilterIndex
End Property
Public Property Let FilterIndex(ByVal lFilterIndex As Long)
    'assign object's FilterIndex property
    m_lFilterIndex = lFilterIndex
End Property
Public Property Get Color() As OLE_COLOR
    'return object's Color property
    Color = m_oColor
End Property
Public Property Let Color(ByVal oColor As OLE_COLOR)
    'assign object's Color property
    m_oColor = oColor
End Property
Public Property Get Copies() As Long
    'return object's Copies property
    Copies = m_lCopies
End Property
Public Property Let Copies(ByVal vNewValue As Long)
    'assign object's Copies property
    m_lCopies = vNewValue
End Property
Public Property Get DefaultExt() As String
    'return object's DefaultExt property
    DefaultExt = m_sDefaultExt
End Property
Public Property Let DefaultExt(ByVal vNewValue As String)
    'assign object's DefaultExt property
    m_sDefaultExt = vNewValue
End Property
Public Property Get DialogTitle() As String
    'return object's FileName property
    DialogTitle = m_sDialogTitle
End Property
Public Property Let DialogTitle(ByVal vNewValue As String)
    'assign object's DialogTitle property
    m_sDialogTitle = vNewValue
End Property
Public Property Get Flags() As Long
    'return object's Flags property
    Flags = m_lFlags
End Property
Public Property Let Flags(ByVal vNewValue As Long)
    'assign object's Flags property
    m_lFlags = vNewValue
End Property
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