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


Private Declare Function MessageBoxEx Lib "user32" _
    Alias "MessageBoxExA" _
    (ByVal hwnd As Long, _
    ByVal lpText As String, _
    ByVal lpCaption As String, _
    ByVal uType As Long, _
    ByVal wLanguageID As Long) As Long
Private Declare Function MessageBoxIndirect Lib "user32" _
    Alias "MessageBoxIndirectA" _
    (lpMsgBoxParams As MSGBOXPARAMS) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
    Alias "GetOpenFileNameA" _
    (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" _
    Alias "GetSaveFileNameA" _
    (pOpenfilename As OPENFILENAME) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" _
    (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" _
    (ByVal pidl As Long, _
    ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function ChooseColor Lib "comdlg32.dll" _
    Alias "ChooseColorA" _
    (pChooseColor As udtCHOOSECOLOR) As Long
Private Declare Function PrintDlg Lib "comdlg32.dll" _
    Alias "PrintDlgA" _
    (pPrintDlg As udtPRINTDLG) As Long
Private Declare Function ChooseFont Lib "comdlg32.dll" _
    Alias "ChooseFontA" _
    (pChooseFont As udtCHOOSEFONT) As Long
Private Declare Function WNetConnectionDialog Lib "mpr.dll" _
    (ByVal hwnd As Long, _
    ByVal dwType As Long) As Long
Private Declare Function WNetDisconnectDialog Lib "mpr.dll" _
    (ByVal hwnd As Long, _
    ByVal dwType As Long) As Long
    
'WNet Dialogs
Public Enum ConnectionType
    RESOURCETYPE_DISK = &H1
    RESOURCETYPE_PRINT = &H2
End Enum

Private Type udtCHOOSECOLOR
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As String      'Long in the API Viewer
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
Private Const CC_ANYCOLOR = &H100
Private Const CC_FULLOPEN = &H2

Private Type OPENFILENAME
    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 udtPRINTDLG
    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 Type MSGBOXPARAMS
    cbSize As Long
    hwndOwner As Long
    hInstance As Long
    lpszText As String
    lpszCaption As String
    dwStyle As Long
    lpszIcon As String
    dwContextHelpId As Long
    lpfnMsgBoxCallback As Long
    dwLanguageId As Long
End Type

'Font Constants
Private Const LF_FACESIZE = 32
Private Const BOLD_FONTTYPE = &H100
Private Const DEVICE_FONTTYPE = &H2
Private Const ITALIC_FONTTYPE = &H200
Private Const PRINTER_FONTTYPE = &H4000
Private Const RASTER_FONTTYPE = &H1
Private Const REGULAR_FONTTYPE = &H400
Private Const SCREEN_FONTTYPE = &H2000
Private Const SIMULATED_FONTTYPE = &H8000
Private Const TRUETYPE_FONTTYPE = &H4
Private Const CF_PRINTERFONTS = &H2
Private Const CF_SCREENFONTS = &H1
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Private Const CF_USESTYLE = &H80&
Private Const CF_EFFECTS = &H100&
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Const CF_LIMITSIZE = &H2000&
Private Const CF_NOSCRIPTSEL = &H800000

Private Const OFN_READONLY = &H1
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_SHOWHELP = &H10
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
Private Const OFN_NONETWORKBUTTON = &H20000
Private Const OFN_NOLONGNAMES = &H40000                    '// force no long names for 4.x modules
Private Const OFN_EXPLORER = &H80000                       '// new look commdlg
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_LONGNAMES = &H200000                     '// force long names for 3.x modules
Private Const OFN_ENABLEINCLUDENOTIFY = &H400000           '// send include message to callback
Private Const OFN_ENABLESIZING = &H800000

Private Type udtCHOOSEFONT
    lStructSize As Long
    hwndOwner As Long          '  caller's window handle
    hdc As Long                '  printer DC/IC or NULL
    lpLogFont As Long
    iPointSize As Long         '  10 * size in points of selected font
    flags As Long              '  enum. type flags
    rgbColors As Long          '  returned text color
    lCustData As Long          '  data passed to hook fn.
    lpfnHook As Long           '  ptr. to hook function
    lpTemplateName As String     '  custom template name
    hInstance As Long          '  instance handle of.EXE that
                                   '    contains cust. dlg. template
    lpszStyle As String          '  return the style field here
                                   '  must be LF_FACESIZE or bigger
    nFontType As Integer          '  same value reported to the EnumFonts
                                   '    call back with the extra FONTTYPE_
                                   '    bits added
    MISSING_ALIGNMENT As Integer
    nSizeMin As Long           '  minimum pt size allowed &
    nSizeMax As Long           '  max pt size allowed if
                                   '    CF_LIMITSIZE is used
End Type

Private Type udtLOGFONT
    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 As String * LF_FACESIZE
End Type

Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000

Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Public Function GetFolder(Optional Title As String, Optional hwnd) As String
    Dim bi As BROWSEINFO
    Dim pidl As Long
    Dim folder As String
    
    folder = Space$(255)
    
    With bi
        If IsNumeric(hwnd) Then .hOwner = hwnd
        .ulFlags = BIF_RETURNONLYFSDIRS
        .pidlRoot = 0
        If Title <> "" Then
            .lpszTitle = Title & Chr$(0)
        Else
            .lpszTitle = "Select a Folder"
        End If
    End With
    
    pidl = SHBrowseForFolder(bi)
    
    If SHGetPathFromIDList(ByVal pidl, ByVal folder) Then
        GetFolder = Left(folder, InStr(folder, Chr$(0)) - 1)
    Else
        GetFolder = ""
    End If
    
    CoTaskMemFree pidl
End Function
Public Function Connect(Mode As ConnectionType, Optional hwnd As Long) As Long
    Dim rc As Long
    
    If IsNumeric(hwnd) Then
        rc = WNetConnectionDialog(hwnd, Mode)
    Else
        rc = WNetConnectionDialog(0, Mode)
    End If
End Function

Public Function Disconnect(Mode As ConnectionType, Optional hwnd As Long) As Long
    Dim rc As Long
    
    If IsNumeric(hwnd) Then
        rc = WNetDisconnectDialog(hwnd, Mode)
    Else
        rc = WNetDisconnectDialog(0, Mode)
    End If