mcommondialog.bas

智能邮件管理信息系统

    StrZToStr = left$(s, lstrlen(s))
End Function

Public Function VBGetSaveFileName2(Filename As String, _
                           Optional FileTitle As String, _
                           Optional OverWritePrompt As Boolean = True, _
                           Optional Filter As String = "All (*.*)| *.*", _
                           Optional FilterIndex As Long = 1, _
                           Optional InitDir As String, _
                           Optional DlgTitle As String, _
                           Optional DefaultExt As String, _
                           Optional Owner As Long = -1, _
                           Optional flags As Long, _
                           Optional Hook As Boolean = False, _
                           Optional hInstance As Long = 0, _
                           Optional TemplateName As Long = 0 _
                        ) As Boolean
Dim opfile As OPENFILENAME, s As String

m_lApiReturn = 0
m_lExtendedError = 0

Filename = Replace(Filename, "\", "")
Filename = Replace(Filename, "/", "")
Filename = Replace(Filename, ":", "")
Filename = Replace(Filename, "*", "")
Filename = Replace(Filename, "?", "")
Filename = Replace(Filename, """", "")
Filename = Replace(Filename, "<", "")
Filename = Replace(Filename, ">", "")
Filename = Replace(Filename, "|", "")

With opfile
   .lStructSize = Len(opfile)
    .hInstance = App.hInstance

   ' Add in specific flags and strip out non-VB flags
   .flags = (-OverWritePrompt * OFN_OVERWRITEPROMPT) Or _
            OFN_HIDEREADONLY
   .flags = .flags And Not OFN_ENABLEHOOK

   ' Owner can take handle of owning window
   If Owner <> -1 Then .hwndOwner = Owner
   ' InitDir can take initial directory string
   .lpstrInitialDir = InitDir
   ' DefaultExt can take default extension
   .lpstrDefExt = DefaultExt
   ' DlgTitle can take dialog box title
   .lpstrTitle = DlgTitle

   If flags And OFN_ENABLETEMPLATE Then
      If hInstance > 0 Then
         .flags = .flags Or OFN_ENABLETEMPLATE
         .hInstance = hInstance
         .lpTemplateName = TemplateName
      End If
   End If

   ' Make new filter with bars (|) replacing nulls and double null at end
   Dim ch As String, i As Integer
   For i = 1 To Len(Filter)
      ch = Mid$(Filter, i, 1)
      If ch = "|" Or ch = ":" Then
         s = s & vbNullChar
      Else
         s = s & ch
      End If
   Next
   ' Put double null at end
   s = s & vbNullChar & vbNullChar
   .lpstrFilter = Filter
   .nFilterIndex = FilterIndex

   ' Pad file and file title buffers to maximum path
   s = Filename & String$(MAX_PATH - Len(Filename), 0)
   .lpstrFile = s
   .nMaxFile = MAX_PATH
'   s = FileTitle & String$(MAX_FILE - Len(FileTitle), 0)
   .lpstrFileTitle = s
   .nMaxFileTitle = MAX_FILE
   ' All other fields zero

'
' 'Set the structure size
'    .lStructSize = Len(opfile)
'    'Set the owner window
'    .hwndOwner = Owner
'    'Set the application's instance
'    .hInstance = App.hInstance
'    'Set the filet
'    .lpstrFilter = Filter
'    'Create a buffer
'    .lpstrFile = Filename 'Space$(254)
'    'Set the maximum number of chars
'    .nMaxFile = 255
'    'Create a buffer
'    .lpstrFileTitle = Space$(254)
'    'Set the maximum number of chars
'    .nMaxFileTitle = 255
'    'Set the initial directory
'    .lpstrInitialDir = InitDir
'    'Set the dialog title
'    .lpstrTitle = DlgTitle
'    'no extra flags
'    .flags = 0



   m_lApiReturn = GetSaveFileName(opfile)

   Select Case m_lApiReturn
   Case 1
      VBGetSaveFileName2 = True
      Filename = StrZToStr(.lpstrFile)
      FileTitle = StrZToStr(.lpstrFileTitle)
      flags = .flags
      ' Return the filter index
      FilterIndex = .nFilterIndex
      ' Look up the filter the user selected and return that
      Filter = FilterLookup(.lpstrFilter, FilterIndex)

   Case 0
      ' Cancelled:
      VBGetSaveFileName2 = False
      Filename = ""
      FileTitle = ""
      flags = 0
      FilterIndex = 0
      Filter = ""

   Case Else
      ' Extended error:
      VBGetSaveFileName2 = False
      m_lExtendedError = CommDlgExtendedError()
      Filename = ""
      FileTitle = ""
      flags = 0
      FilterIndex = 0
      Filter = ""

   End Select
End With

Filename = Replace(Filename, String$(1, 0), "")

End Function

Function VBGetSaveFileName(Filename As String, _
                           Optional FileTitle As String, _
                           Optional OverWritePrompt As Boolean = True, _
                           Optional Filter As String = "All (*.*)| *.*", _
                           Optional FilterIndex As Long = 1, _
                           Optional InitDir As String, _
                           Optional DlgTitle As String, _
                           Optional DefaultExt As String, _
                           Optional Owner As Long = -1, _
                           Optional flags As Long, _
                           Optional Hook As Boolean = False _
                        ) As Boolean
   flags = flags And Not OFN_ENABLETEMPLATE
   VBGetSaveFileName = VBGetSaveFileName2(Filename, FileTitle, OverWritePrompt, _
            Filter, FilterIndex, InitDir, DlgTitle, DefaultExt, _
            Owner, flags, Hook)
End Function

Private Function FilterLookup(ByVal sFilters As String, ByVal iCur As Long) As String
    Dim iStart As Long, iEnd As Long, s As String
    iStart = 1
    If sFilters = "" Then Exit Function
    Do
        ' Cut out both parts marked by null character
        iEnd = InStr(iStart, sFilters, vbNullChar)
        If iEnd = 0 Then Exit Function
        iEnd = InStr(iEnd + 1, sFilters, vbNullChar)
        If iEnd Then
            s = Mid$(sFilters, iStart, iEnd - iStart)
        Else
            s = Mid$(sFilters, iStart)
        End If
        iStart = iEnd + 1
        If iCur = 1 Then
            FilterLookup = s
            Exit Function
        End If
        iCur = iCur - 1
    Loop While iCur
End Function

Function VBGetFileTitle(sFile As String) As String
    Dim sFileTitle As String, cFileTitle As Integer

    cFileTitle = MAX_PATH
    sFileTitle = String$(MAX_PATH, 0)
    cFileTitle = GetFileTitle(sFile, sFileTitle, MAX_PATH)
    If cFileTitle Then
        VBGetFileTitle = ""
    Else
        VBGetFileTitle = left$(sFileTitle, InStr(sFileTitle, vbNullChar) - 1)
    End If

End Function

' ChooseColor wrapper
Function VBChooseColor(Color As Long, _
                       Optional AnyColor As Boolean = True, _
                       Optional FullOpen As Boolean = False, _
                       Optional DisableFullOpen As Boolean = False, _
                       Optional Owner As Long = -1, _
                       Optional flags As Long, _
                       Optional Hook As Boolean = False _
                    ) As Boolean

    Dim chclr As TCHOOSECOLOR
    chclr.lStructSize = Len(chclr)

    ' Color must get reference variable to receive result
    ' Flags can get reference variable or constant with bit flags
    ' Owner can take handle of owning window
    If Owner <> -1 Then chclr.hwndOwner = Owner

    ' Assign color (default uninitialized value of zero is good default)
    chclr.rgbResult = Color

    ' Mask out unwanted bits
    Dim afMask As Long
    afMask = CLng(Not (CC_ENABLEHOOK Or _
                       CC_ENABLETEMPLATE))
    ' Pass in flags
    chclr.flags = afMask And (CC_RGBInit Or _
                  IIf(AnyColor, CC_AnyColor, CC_SolidColor) Or _
                  (-FullOpen * CC_FullOpen) Or _
                  (-DisableFullOpen * CC_PreventFullOpen))


    ' If first time, initialize to white
    If fNotFirst = False Then InitColors

    chclr.lpCustColors = VarPtr(alCustom(0))
    ' All other fields zero

    m_lApiReturn = ChooseColor(chclr)

    Select Case m_lApiReturn
    Case 1
        ' Success
        VBChooseColor = True
        Color = chclr.rgbResult
    Case 0
        ' Cancelled
        VBChooseColor = False
        Color = -1
    Case Else
        ' Extended error
        m_lExtendedError = CommDlgExtendedError()
        VBChooseColor = False
        Color = -1
    End Select

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
    fNotFirst = True
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 first time, initialize to white
    If fNotFirst = False Then InitColors
    If i >= 0 And i <= 15 Then
        CustomColor = alCustom(i)
    Else
        CustomColor = -1
    End If
End Property

Public Property Let CustomColor(i As Integer, iValue As Long)
    ' If first time, initialize to system colors
    If fNotFirst = False Then InitColors
    If i >= 0 And i <= 15 Then
        alCustom(i) = iValue
    End If
End Property

' ChooseFont wrapper
Function VBChooseFont(CurFont As Font, _
                      Optional PrinterDC As Long = -1, _
                      Optional Owner As Long = -1, _
                      Optional Color As Long = vbBlack, _
                      Optional MinSize As Long = 0, _
                      Optional MaxSize As Long = 0, _
                      Optional flags As Long = 0, _
                      Optional Hook As Boolean = False _
                    ) As Boolean

    m_lApiReturn = 0
    m_lExtendedError = 0

    ' Unwanted Flags bits
    Const CF_FontNotSupported = CF_Apply Or CF_EnableHook Or CF_EnableTemplate

    ' Flags can get reference variable or constant with bit flags
    ' PrinterDC can take printer DC
    If PrinterDC = -1 Then
        PrinterDC = 0
        If flags And CF_PrinterFonts Then PrinterDC = Printer.hdc
    Else
        flags = flags Or CF_PrinterFonts
    End If
    ' Must have some fonts
    If (flags And CF_PrinterFonts) = 0 Then flags = flags Or CF_ScreenFonts
    ' Color can take initial color, receive chosen color
    If Color <> vbBlack Then flags = flags Or CF_EFFECTS
    ' MinSize can be minimum size accepted
    If MinSize Then flags = flags Or CF_LimitSize
    ' MaxSize can be maximum size accepted
    If MaxSize Then flags = flags Or CF_LimitSize

    ' Put in required internal flags and remove unsupported
    flags = (flags Or CF_InitToLogFontStruct) And Not CF_FontNotSupported

    ' Initialize LOGFONT variable
    Dim fnt As LOGFONT
    Const PointsPerTwip = 1440 / 72
    fnt.lfHeight = -(CurFont.Size * (PointsPerTwip / Screen.TwipsPerPixelY))
    fnt.lfWeight = CurFont.Weight
    fnt.lfItalic = CurFont.Italic
    fnt.lfUnderline = CurFont.Underline
    fnt.lfStrikeOut = CurFont.Strikethrough
    ' Other fields zero
    StrToBytes fnt.lfFaceName, CurFont.Name

    ' Initialize TCHOOSEFONT variable
    Dim cf As TCHOOSEFONT
    cf.lStructSize = Len(cf)
    If Owner <> -1 Then cf.hwndOwner = Owner
    cf.hdc = PrinterDC
    cf.lpLogFont = VarPtr(fnt)
    cf.iPointSize = CurFont.Size * 10
    cf.flags = flags
    cf.rgbColors = Color
    cf.nSizeMin = MinSize
    cf.nSizeMax = MaxSize

    ' All other fields zero
    m_lApiReturn = ChooseFont(cf)

    Select Case m_lApiReturn
    Case 1
        ' Success
        VBChooseFont = True
        flags = cf.flags
        Color = cf.rgbColors
        CurFont.Bold = cf.nFontType And Bold_FontType
        'CurFont.Italic = cf.nFontType And Italic_FontType
        CurFont.Italic = fnt.lfItalic
        CurFont.Strikethrough = fnt.lfStrikeOut
        CurFont.Underline = fnt.lfUnderline
        CurFont.Weight = fnt.lfWeight
        CurFont.Size = cf.iPointSize / 10
        CurFont.Name = BytesToStr(fnt.lfFaceName)
    Case 0
        ' Cancelled
        VBChooseFont = False
    Case Else
        ' Extended error
        m_lExtendedError = CommDlgExtendedError()
        VBChooseFont = False
    End Select

End Function

' PrintDlg wrapper
Function VBPrintDlg(hdc As Long, _
                    Optional PrintRange As EPrintRange = eprAll, _
                    Optional DisablePageNumbers As Boolean, _
                    Optional FromPage As Long = 1, _
                    Optional ToPage As Long = &HFFFF, _
                    Optional DisableSelection As Boolean, _
                    Optional Copies As Integer, _
                    Optional ShowPrintToFile As Boolean, _
                    Optional DisablePrintToFile As Boolean = True, _
                    Optional PrintToFile As Boolean, _
                    Optional Collate As Boolean, _
                    Optional PreventWarning As Boolean, _