clsdialogs.cls

销售预测系统

End Function


Public Function FileOpen(Optional Title As String, _
        Optional StartPath As String, _
        Optional Filter As String, _
        Optional FilterIndex As Long, _
        Optional hwnd) As String
        
    Dim rc As Long
    Dim pOpenfilename As OPENFILENAME
    Const MAX_BUFFER_LENGTH = 256
    
    With pOpenfilename
        If IsNumeric(hwnd) Then .hwndOwner = hwnd
        .hInstance = App.hInstance
        If Title <> "" Then
            .lpstrTitle = Title
        Else
            .lpstrTitle = "Open"
        End If
        If StartPath <> "" Then
            .lpstrInitialDir = StartPath
        Else
            .lpstrInitialDir = App.Path
        End If
        If Filter <> "" Then
            .lpstrFilter = Filter
        Else
            .lpstrFilter = "All Files" & Chr$(0) & "*.*" & Chr$(0)
        End If
        If IsNumeric(FilterIndex) Then .nFilterIndex = FilterIndex
        .lpstrFile = String(MAX_BUFFER_LENGTH, 0)
        .nMaxFile = MAX_BUFFER_LENGTH - 1
        .lpstrFileTitle = .lpstrFile
        .nMaxFileTitle = MAX_BUFFER_LENGTH
        .lStructSize = Len(pOpenfilename)
    End With
    
    rc = GetOpenFileName(pOpenfilename)
    
    If rc <> 0 Then
        'A file selected
        FileOpen = Left$(pOpenfilename.lpstrFile, pOpenfilename.nMaxFile)
    Else
        'The cancel button was pressed
        FileOpen = ""
    End If
End Function

Public Function FilePrint(Copies As Integer, FromPage As Integer, ToPage As Integer, MinPage As Integer, MaxPage As Integer, Optional hwnd As Long) As Long
    Dim rc As Long
    Dim pPrintDlg As udtPRINTDLG
    
    With pPrintDlg
        If IsNumeric(hwnd) Then
            .hwndOwner = hwnd
        Else
            .hwndOwner = 0
        End If
        .flags = 0
        .hInstance = App.hInstance
        .nCopies = Copies
        .nFromPage = FromPage
        .nToPage = ToPage
        .nMinPage = MinPage
        .nMaxPage = MaxPage
        .lStructSize = Len(pPrintDlg)
    End With
    
    'Call the API
    rc = PrintDlg(pPrintDlg)
    If rc = 0 Then
        'Fetch the settings
        With pPrintDlg
            Copies = .nCopies
            FromPage = .nFromPage
            ToPage = .nToPage
            MinPage = .nMinPage
            MaxPage = .nMaxPage
        End With
    Else
    End If
End Function
Public Function FileSave(Optional Title As String, _
        Optional StartPath As String, _
        Optional DefaultExtension As String, _
        Optional Filter As String, _
        Optional FilterIndex As Long, _
        Optional hwnd) As String
    
    Dim rc As Long
    Dim pOpenfilename As OPENFILENAME
    Const MAX_BUFFER_LENGTH = 256
    
    With pOpenfilename
        If IsNumeric(hwnd) Then .hwndOwner = hwnd
        .hInstance = App.hInstance
        If Title <> "" Then
            .lpstrTitle = Title
        Else
            .lpstrTitle = "Save"
        End If
        If StartPath <> "" Then
            .lpstrInitialDir = StartPath
        Else
            .lpstrInitialDir = App.Path
        End If
        If Filter <> "" Then
            .lpstrFilter = Filter
        Else
            .lpstrFilter = "All Files" & Chr$(0) & "*.*" & Chr$(0)
        End If
        If DefaultExtension <> "" Then .lpstrDefExt = DefaultExtension
        If IsNumeric(FilterIndex) Then .nFilterIndex = FilterIndex
        .lpstrFile = String(MAX_BUFFER_LENGTH, 0)
        .nMaxFile = MAX_BUFFER_LENGTH - 1
        .lpstrFileTitle = .lpstrFile
        .nMaxFileTitle = MAX_BUFFER_LENGTH
        .lStructSize = Len(pOpenfilename)
        .flags = OFN_SHAREAWARE
    End With
    
    rc = GetSaveFileName(pOpenfilename)
    
    If rc <> 0 Then
        'A file selected
        FileSave = Left$(pOpenfilename.lpstrFile, pOpenfilename.nMaxFile)
    Else
        'The cancel button was pressed
        FileSave = ""
    End If
End Function


Public Function GetColor(DefaultColor As Long, Optional hwnd As Long) As Long
    Dim rc As Long
    Dim pChooseColor As udtCHOOSECOLOR
    Dim CustomColors() As Byte
    
    'Initailize the UDT for the color dialog
    With pChooseColor
        If IsNumeric(hwnd) Then
            .hwndOwner = hwnd
        Else
            .hwndOwner = 0
        End If
        .hInstance = 0
        .lpCustColors = StrConv(CustomColors, vbUnicode)
        .flags = 0
        .lStructSize = Len(pChooseColor)
    End With
    
    'Call the API
    rc = ChooseColor(pChooseColor)
          
    'Return the RGB value of the color
    If rc Then
        GetColor = pChooseColor.rgbResult
    Else
        GetColor = DefaultColor
    End If
End Function




Public Function GetFont(Optional FontName As String, _
        Optional Size As Integer, _
        Optional Bold As Boolean, _
        Optional Italic As Boolean, _
        Optional Underline As Boolean, _
        Optional Strikeout As Boolean, _
        Optional Color As Long, _
        Optional hwnd) As Long
    
    Dim rc As Long
    Dim pChooseFont As udtCHOOSEFONT
    Dim pLogFont As udtLOGFONT
    
    'Initailize the buffer
    With pLogFont
        .lfFaceName = FontName & Chr$(0)
        .lfItalic = Italic
        .lfUnderline = Underline
        .lfStrikeOut = Strikeout
    End With
    
    'Initialize the structure
    With pChooseFont
        .hInstance = App.hInstance
        If IsNumeric(hwnd) Then .hwndOwner = hwnd
        .flags = CF_BOTH + CF_INITTOLOGFONTSTRUCT + _
            CF_EFFECTS + CF_NOSCRIPTSEL
            
        If IsNumeric(Size) Then .iPointSize = -(Size * 10)
        If Bold Then .nFontType = .nFontType + BOLD_FONTTYPE
        If Italic Then .nFontType = .nFontType + ITALIC_FONTTYPE
        If IsNumeric(Color) Then .rgbColors = Color
        
        .lStructSize = Len(pChooseFont)
        .lpLogFont = VarPtr(pLogFont)
    End With
    
    'Call the API
    rc = ChooseFont(pChooseFont)
    
    If rc <> 0 Then
        'Success!
        FontName = StrConv(pLogFont.lfFaceName, vbUnicode)
        FontName = Left$(FontName, InStr(FontName, vbNullChar) - 1)
        
        'Return it's properties
        With pChooseFont
            Size = .iPointSize / 10
            Bold = (.nFontType And BOLD_FONTTYPE)
            Italic = (.nFontType And ITALIC_FONTTYPE)
            Underline = (pLogFont.lfUnderline)
            Strikeout = (pLogFont.lfStrikeOut)
        End With
        
        'Return the font name
        GetFont = rc
    Else
        'The user clicked cancel
        GetFont = 0
    End If
End Function

Public Function YesNoBox(Message As String, Caption As String, Optional hwndOwner As Long) As Long
    Dim rc As Long
    Dim hwnd As Long
    Dim wLanguageID As Long
    
    If IsNumeric(hwndOwner) Then
        hwnd = hwndOwner
    Else
        hwnd = 0
    End If
    
    YesNoBox = MessageBoxEx(hwnd, _
            Message, _
            Caption, _
            vbYesNo + vbQuestion, _
            wLanguageID)
End Function

Public Function WarningBox(Message As String, Caption As String, Optional hwndOwner As Long) As Long
    Dim rc As Long
    Dim hwnd As Long
    Dim wLanguageID As Long
    
    If IsNumeric(hwndOwner) Then
        hwnd = hwndOwner
    Else
        hwnd = 0
    End If
    
    WarningBox = MessageBoxEx(hwnd, _
            Message, _
            Caption, _
            vbExclamation, _
            wLanguageID)
End Function
Public Function ErrorBox(Message As String, Caption As String, Optional hwndOwner As Long) As Long
    Dim rc As Long
    Dim hwnd As Long
    Dim wLanguageID As Long
    
    If IsNumeric(hwndOwner) Then
        hwnd = hwndOwner
    Else
        hwnd = 0
    End If
    
    ErrorBox = MessageBoxEx(hwnd, _
            Message, _
            Caption, _
            vbOK + vbCritical, _
            wLanguageID)
End Function