怎样才能不使用控件而用API实现“文件保存”对话框?

Question

VB里带一个DialogBox控件，用ShowSave方法即可！！

Answer 1

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 TypePrivate Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Answer 2

Private Function ShowSave() As String
    'Set the structure size
    OFName.lStructSize = Len(OFName)
    'Set the owner window
    OFName.hwndOwner = Me.hwnd
    'Set the application's instance
    OFName.hInstance = App.hInstance
    'Set the filet
    OFName.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
    'Create a buffer
    OFName.lpstrFile = Space$(254)
    'Set the maximum number of chars
    OFName.nMaxFile = 255
    'Create a buffer
    OFName.lpstrFileTitle = Space$(254)
    'Set the maximum number of chars
    OFName.nMaxFileTitle = 255
    'Set the initial directory
    OFName.lpstrInitialDir = "C:\"
    'Set the dialog title
    OFName.lpstrTitle = "Save File - KPD-Team 1998"
    'no extra flags
    OFName.flags = 0    'Show the 'Save File'-dialog
    If GetSaveFileName(OFName) Then
        ShowSave = Trim$(OFName.lpstrFile)
    Else
        ShowSave = ""
    End If
End Function

Answer 3

加上这样的定义
Dim OFName As OPENFILENAME

Answer 4

'This project needs 6 command buttons
Option Explicit
Const FW_NORMAL = 400
Const DEFAULT_CHARSET = 1
Const OUT_DEFAULT_PRECIS = 0
Const CLIP_DEFAULT_PRECIS = 0
Const DEFAULT_QUALITY = 0
Const DEFAULT_PITCH = 0
Const FF_ROMAN = 16
Const CF_PRINTERFONTS = &H2
Const CF_SCREENFONTS = &H1
Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Const CF_EFFECTS = &H100&
Const CF_FORCEFONTEXIST = &H10000
Const CF_INITTOLOGFONTSTRUCT = &H40&
Const CF_LIMITSIZE = &H2000&
Const REGULAR_FONTTYPE = &H400
Const LF_FACESIZE = 32
Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40
Const DM_DUPLEX = &H1000&
Const DM_ORIENTATION = &H1&
Const PD_PRINTSETUP = &H40
Const PD_DISABLEPRINTTOFILE = &H80000
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
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 PAGESETUPDLG
    lStructSize As Long
    hwndOwner As Long
    hDevMode As Long
    hDevNames As Long
    flags As Long
    ptPaperSize As POINTAPI
    rtMinMargin As RECT
    rtMargin As RECT
    hInstance As Long
    lCustData As Long
    lpfnPageSetupHook As Long
    lpfnPagePaintHook As Long
    lpPageSetupTemplateName As String
    hPageSetupTemplate As Long
End Type
Private Type CHOOSECOLOR
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As String
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
Private Type LOGFONT
        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 * 31
End Type
Private Type CHOOSEFONT
        lStructSize As Long
        hwndOwner As Long          '  caller's window handle
        hDC As Long                '  printer DC/IC or NULL
        lpLogFont As Long          '  ptr. to a LOGFONT struct
        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 PRINTDLG_TYPE
    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 DEVNAMES_TYPE
    wDriverOffset As Integer
    wDeviceOffset As Integer
    wOutputOffset As Integer
    wDefault As Integer
    extra As String * 100
End Type
Private Type DEVMODE_TYPE
    dmDeviceName As String * CCHDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCHFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type
Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) 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 PrintDialog Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLG_TYPE) As Long
Private Declare Function PAGESETUPDLG Lib "comdlg32.dll" Alias "PageSetupDlgA" (pPagesetupdlg As PAGESETUPDLG) As Long
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Dim OFName As OPENFILENAME
Dim CustomColors() As Byte
Private Sub Command1_Click()
    Dim sFile As String
    sFile = ShowOpen
    If sFile <> "" Then
        MsgBox "You chose this file: " + sFile
    Else
        MsgBox "You pressed cancel"
    End If
End Sub
Private Sub Command2_Click()
    Dim sFile As String
    sFile = ShowSave
    If sFile <> "" Then
        MsgBox "You chose this file: " + sFile
    Else
        MsgBox "You pressed cancel"
    End If
End Sub
Private Sub Command3_Click()
    Dim NewColor As Long
    NewColor = ShowColor
    If NewColor <> -1 Then
        Me.BackColor = NewColor
    Else
        MsgBox "You chose cancel"
    End If
End Sub
Private Sub Command4_Click()
    MsgBox ShowFont
End Sub
Private Sub Command5_Click()
    ShowPrinter Me
End Sub
Private Sub Command6_Click()
    ShowPageSetupDlg
End Sub
Private Sub Form_Load()
    'KPD-Team 1998
    'URL: http://www.allapi.net/
    'E-Mail: [email protected]
    'Redim the variables to store the cutstom colors
    ReDim CustomColors(0 To 16 * 4 - 1) As Byte
    Dim i As Integer
    For i = LBound(CustomColors) To UBound(CustomColors)
        CustomColors(i) = 0
    Next i
    'Set the captions
    Command1.Caption = "ShowOpen"
    Command2.Caption = "ShowSave"
    Command3.Caption = "ShowColor"
    Command4.Caption = "ShowFont"
    Command5.Caption = "ShowPrinter"
    Command6.Caption = "ShowPageSetupDlg"
End Sub
Private Function ShowColor() As Long
    Dim cc As CHOOSECOLOR
    Dim Custcolor(16) As Long
    Dim lReturn As Long    'set the structure size
    cc.lStructSize = Len(cc)
    'Set the owner
    cc.hwndOwner = Me.hwnd
    'set the application's instance
    cc.hInstance = App.hInstance
    'set the custom colors (converted to Unicode)
    cc.lpCustColors = StrConv(CustomColors, vbUnicode)
    'no extra flags
    cc.flags = 0    'Show the 'Select Color'-dialog
    If CHOOSECOLOR(cc) <> 0 Then
        ShowColor = cc.rgbResult
        CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
    Else
        ShowColor = -1
    End If
End Function
Private Function ShowOpen() As String
    'Set the structure size
    OFName.lStructSize = Len(OFName)
    'Set the owner window
    OFName.hwndOwner = Me.hwnd
    'Set the application's instance
    OFName.hInstance = App.hInstance
    'Set the filet
    OFName.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
    'Create a buffer
    OFName.lpstrFile = Space$(254)
    'Set the maximum number of chars
    OFName.nMaxFile = 255
    'Create a buffer
    OFName.lpstrFileTitle = Space$(254)
    'Set the maximum number of chars
    OFName.nMaxFileTitle = 255
    'Set the initial directory
    OFName.lpstrInitialDir = "C:\"
    'Set the dialog title
    OFName.lpstrTitle = "Open File - KPD-Team 1998"
    'no extra flags
    OFName.flags = 0    'Show the 'Open File'-dialog
    If GetOpenFileName(OFName) Then
        ShowOpen = Trim$(OFName.lpstrFile)
    Else
        ShowOpen = ""
    End If
End Function
Private Function ShowFont() As String
    Dim cf As CHOOSEFONT, lfont As LOGFONT, hMem As Long, pMem As Long
    Dim fontname As String, retval As Long
    lfont.lfHeight = 0  ' determine default height
    lfont.lfWidth = 0  ' determine default width
    lfont.lfEscapement = 0  ' angle between baseline and escapement vector
    lfont.lfOrientation = 0  ' angle between baseline and orientation vector
    lfont.lfWeight = FW_NORMAL  ' normal weight i.e. not bold
    lfont.lfCharSet = DEFAULT_CHARSET  ' use default character set
    lfont.lfOutPrecision = OUT_DEFAULT_PRECIS  ' default precision mapping
    lfont.lfClipPrecision = CLIP_DEFAULT_PRECIS  ' default clipping precision
    lfont.lfQuality = DEFAULT_QUALITY  ' default quality setting
    lfont.lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN  ' default pitch, proportional with serifs
    lfont.lfFaceName = "Times New Roman" & vbNullChar  ' string must be null-terminated
    ' Create the memory block which will act as the LOGFONT structure buffer.
    hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lfont))
    pMem = GlobalLock(hMem)  ' lock and get pointer
    CopyMemory ByVal pMem, lfont, Len(lfont)  ' copy structure's contents into block
    ' Initialize dialog box: Screen and printer fonts, point size between 10 and 72.
    cf.lStructSize = Len(cf)  ' size of structure
    cf.hwndOwner = Form1.hwnd  ' window Form1 is opening this dialog box
    cf.hDC = Printer.hDC  ' device context of default printer (using VB's mechanism)
    cf.lpLogFont = pMem   ' pointer to LOGFONT memory block buffer
    cf.iPointSize = 120  ' 12 point font (in units of 1/10 point)
    cf.flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
    cf.rgbColors = RGB(0, 0, 0)  ' black
    cf.nFontType = REGULAR_FONTTYPE  ' regular font type i.e. not bold or anything
    cf.nSizeMin = 10  ' minimum point size
    cf.nSizeMax = 72  ' maximum point size
    ' Now, call the function.  If successful, copy the LOGFONT structure back into the structure
    ' and then print out the attributes we mentioned earlier that the user selected.
    retval = CHOOSEFONT(cf)  ' open the dialog box
    If retval <> 0 Then  ' success
        CopyMemory lfont, ByVal pMem, Len(lfont)  ' copy memory back
        ' Now make the fixed-length string holding the font name into a "normal" string.
        ShowFont = Left(lfont.lfFaceName, InStr(lfont.lfFaceName, vbNullChar) - 1)
        Debug.Print  ' end the line
    End If
    ' Deallocate the memory block we created earlier.  Note that this must
    ' be done whether the function succeeded or not.
    retval = GlobalUnlock(hMem)  ' destroy pointer, unlock block
    retval = GlobalFree(hMem)  ' free the allocated memory
End Function
Private Function ShowSave() As String
    'Set the structure size
    OFName.lStructSize = Len(OFName)
    'Set the owner window
    OFName.hwndOwner = Me.hwnd
    'Set the application's instance
    OFName.hInstance = App.hInstance
    'Set the filet
    OFName.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
    'Create a buffer
    OFName.lpstrFile = Space$(254)
    'Set the maximum number of chars
    OFName.nMaxFile = 255
    'Create a buffer
    OFName.lpstrFileTitle = Space$(254)
    'Set the maximum number of chars
    OFName.nMaxFileTitle = 255
    'Set the initial directory
    OFName.lpstrInitialDir = "C:\"
    'Set the dialog title
    OFName.lpstrTitle = "Save File - KPD-Team 1998"
    'no extra flags
    OFName.flags = 0    'Show the 'Save File'-dialog
    If GetSaveFileName(OFName) Then
        ShowSave = Trim$(OFName.lpstrFile)
    Else
        ShowSave = ""
    End If
End Function
Private Function ShowPageSetupDlg() As Long
    Dim m_PSD As PAGESETUPDLG
    'Set the structure size
    m_PSD.lStructSize = Len(m_PSD)
    'Set the owner window
    m_PSD.hwndOwner = Me.hwnd
    'Set the application instance
    m_PSD.hInstance = App.hInstance
    'no extra flags
    m_PSD.flags = 0    'Show the pagesetup dialog
    If PAGESETUPDLG(m_PSD) Then
        ShowPageSetupDlg = 0
    Else
        ShowPageSetupDlg = -1
    End If
End Function
Public Sub ShowPrinter(frmOwner As Form, Optional PrintFlags As Long)
    '-> Code by Donald Grover
    Dim PrintDlg As PRINTDLG_TYPE
    Dim DevMode As DEVMODE_TYPE
    Dim DevName As DEVNAMES_TYPE    Dim lpDevMode As Long, lpDevName As Long
    Dim bReturn As Integer
    Dim objPrinter As Printer, NewPrinterName As String    ' Use PrintDialog to get the handle to a memory
    ' block with a DevMode and DevName structures    PrintDlg.lStructSize = Len(PrintDlg)
    PrintDlg.hwndOwner = frmOwner.hwnd    PrintDlg.flags = PrintFlags
    On Error Resume Next
    'Set the current orientation and duplex setting
    DevMode.dmDeviceName = Printer.DeviceName
    DevMode.dmSize = Len(DevMode)
    DevMode.dmFields = DM_ORIENTATION Or DM_DUPLEX
    DevMode.dmPaperWidth = Printer.Width
    DevMode.dmOrientation = Printer.Orientation
    DevMode.dmPaperSize = Printer.PaperSize
    DevMode.dmDuplex = Printer.Duplex
    On Error GoTo 0    'Allocate memory for the initialization hDevMode structure
    'and copy the settings gathered above into this memory
    PrintDlg.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevMode))
    lpDevMode = GlobalLock(PrintDlg.hDevMode)
    If lpDevMode > 0 Then
        CopyMemory ByVal lpDevMode, DevMode, Len(DevMode)
        bReturn = GlobalUnlock(PrintDlg.hDevMode)
    End If    'Set the current driver, device, and port name strings
    With DevName
        .wDriverOffset = 8
        .wDeviceOffset = .wDriverOffset + 1 + Len(Printer.DriverName)
        .wOutputOffset = .wDeviceOffset + 1 + Len(Printer.Port)
        .wDefault = 0
    End With    With Printer
        DevName.extra = .DriverName & Chr(0) & .DeviceName & Chr(0) & .Port & Chr(0)
    End With    'Allocate memory for the initial hDevName structure
    'and copy the settings gathered above into this memory
    PrintDlg.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevName))
    lpDevName = GlobalLock(PrintDlg.hDevNames)
    If lpDevName > 0 Then
        CopyMemory ByVal lpDevName, DevName, Len(DevName)
        bReturn = GlobalUnlock(lpDevName)
    End If    'Call the print dialog up and let the user make changes
    If PrintDialog(PrintDlg) <> 0 Then        'First get the DevName structure.
        lpDevName = GlobalLock(PrintDlg.hDevNames)
        CopyMemory DevName, ByVal lpDevName, 45
        bReturn = GlobalUnlock(lpDevName)
        GlobalFree PrintDlg.hDevNames        'Next get the DevMode structure and set the printer
        'properties appropriately
        lpDevMode = GlobalLock(PrintDlg.hDevMode)
        CopyMemory DevMode, ByVal lpDevMode, Len(DevMode)
        bReturn = GlobalUnlock(PrintDlg.hDevMode)
        GlobalFree PrintDlg.hDevMode
        NewPrinterName = UCase$(Left(DevMode.dmDeviceName, InStr(DevMode.dmDeviceName, Chr$(0)) - 1))
        If Printer.DeviceName <> NewPrinterName Then
            For Each objPrinter In Printers
                If UCase$(objPrinter.DeviceName) = NewPrinterName Then
                    Set Printer = objPrinter
                    'set printer toolbar name at this point
                End If
            Next
        End If        On Error Resume Next
        'Set printer object properties according to selections made
        'by user
        Printer.Copies = DevMode.dmCopies
        Printer.Duplex = DevMode.dmDuplex
        Printer.Orientation = DevMode.dmOrientation
        Printer.PaperSize = DevMode.dmPaperSize
        Printer.PrintQuality = DevMode.dmPrintQuality
        Printer.ColorMode = DevMode.dmColor
        Printer.PaperBin = DevMode.dmDefaultSource
        On Error GoTo 0
    End If
End Sub

Answer 5

为什么不下一个 Win32API 超级工具？

Answer 6

添到类模块中Option ExplicitPrivate 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 Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long'&Euml;&frac12;&Oacute;&ETH;&Ecirc;&ocirc;&ETH;&Ocirc;±&auml;&Aacute;&iquest;
Private ptHwnd As Long
Private ptTitle As String
Private ptFileName As String
Private ptFileTitle As String
Private ptInitDir As String
Private ptFilter As String'&sup1;&laquo;&sup1;&sup2;&Ecirc;&ocirc;&ETH;&Ocirc;
Property Let Hwnd(theHwnd As Long)
    ptHwnd = theHwnd
End PropertyProperty Let Title(theTitle As String)
    ptTitle = theTitle
End PropertyProperty Let InitDir(theInitDir As String)
    ptInitDir = theInitDir
End PropertyProperty Let Filter(theFilter As String)
    ptFilter = theFilter
End PropertyProperty Get FileName() As String
    FileName = ptFileName
End PropertyProperty Get FileTitle() As String
    FileTitle = ptFileTitle
End PropertyPublic Sub ShowOpen()
Dim file As OPENFILENAME, ret As Long, NullPos As Integer
    file.hwndOwner = ptHwnd
    file.lpstrTitle = ptTitle
    file.lpstrInitialDir = ptInitDir
    file.lpstrFilter = ptFilter
    file.lpstrFile = Space(255)
    file.nMaxFile = 256
    file.lpstrFileTitle = Space(255)
    file.nMaxFileTitle = 255
    file.flags = False
    file.lStructSize = Len(file)
    file.hInstance = 1
    ret = GetOpenFileName(file)
    If ret = 0 Then
        ptFileName = ""
        ptFileTitle = ""
    Else
        NullPos = InStr(1, file.lpstrFile, Chr(0), vbBinaryCompare)
        ptFileName = Left(file.lpstrFile, NullPos - 1)
        NullPos = InStr(1, file.lpstrFileTitle, Chr(0), vbBinaryCompare)
        ptFileTitle = Left(file.lpstrFileTitle, NullPos - 1)
    End If
End Sub

Answer 7

'文件枚举
Private Enum EOpenFile
    OFN_READONLY = &H1
    OFN_OVERWRITEPROMPT = &H2
    OFN_HIDEREADONLY = &H4
    OFN_NOCHANGEDIR = &H8
    OFN_SHOWHELP = &H10
    OFN_ENABLEHOOK = &H20
    OFN_ENABLETEMPLATE = &H40
    OFN_ENABLETEMPLATEHANDLE = &H80
    OFN_NOVALIDATE = &H100
    OFN_ALLOWMULTISELECT = &H200
    OFN_EXTENSIONDIFFERENT = &H400
    OFN_PATHMUSTEXIST = &H800
    OFN_FILEMUSTEXIST = &H1000
    OFN_CREATEPROMPT = &H2000
    OFN_SHAREAWARE = &H4000
    OFN_NOREADONLYRETURN = &H8000
    OFN_NOTESTFILECREATE = &H10000
    OFN_NONETWORKBUTTON = &H20000
    OFN_NOLONGNAMES = &H40000
    OFN_EXPLORER = &H80000
    OFN_NODEREFERENCELINKS = &H100000
    OFN_LONGNAMES = &H200000
End Enum
Private Const MAX_PATH = 260Private Type OPENFILENAME
    lStructSize As Long          ' Filled with UDT size
    hwndOwner As Long            ' Tied to Owner
    hInstance As Long            ' Ignored (used only by templates)
    lpstrFilter As String        ' Tied to Filter
    lpstrCustomFilter As String  ' Ignored (exercise for reader)
    nMaxCustFilter As Long       ' Ignored (exercise for reader)
    nFilterIndex As Long         ' Tied to FilterIndex
    lpstrFile As String          ' Tied to FileName
    nMaxFile As Long             ' Handled internally
    lpstrFileTitle As String     ' Tied to FileTitle
    nMaxFileTitle As Long        ' Handled internally
    lpstrInitialDir As String    ' Tied to InitDir
    lpstrTitle As String         ' Tied to DlgTitle
    flags As Long                ' Tied to Flags
    nFileOffset As Integer       ' Ignored (exercise for reader)
    nFileExtension As Integer    ' Ignored (exercise for reader)
    lpstrDefExt As String        ' Tied to DefaultExt
    lCustData As Long            ' Ignored (needed for hooks)
    lpfnHook As Long             ' Ignored (good luck with hooks)
    lpTemplateName As Long       ' Ignored (good luck with templates)
End TypePrivate Declare Function GetOpenFileName Lib "COMDLG32" _
    Alias "GetOpenFileNameA" (file As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "COMDLG32" _
    Alias "GetSaveFileNameA" (file As OPENFILENAME) As LongPrivate Declare Function CommDlgExtendedError Lib "COMDLG32" () As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As LongPrivate m_lApiReturn As Long
Private m_lExtendedError As LongPrivate Const MAX_FILE = 260&Public Function fGetOpenFileName(Filename As String, _
                           Optional FileTitle As String, _
                           Optional FileMustExist As Boolean = True, _
                           Optional MultiSelect As Boolean = False, _
                           Optional ReadOnly As Boolean = False, _
                           Optional HideReadOnly As Boolean = False, _
                           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 = 0) As Boolean    Dim opfile As OPENFILENAME, s As String, afFlags As Long
    Dim lMax As Long
    
    On Error Resume Next
    m_lApiReturn = 0
    m_lExtendedError = 0    With opfile
        .lStructSize = Len(opfile)
        .flags = (-FileMustExist * OFN_FILEMUSTEXIST) Or _
                (-MultiSelect * OFN_ALLOWMULTISELECT) Or _
                 (-ReadOnly * OFN_READONLY) Or _
                 (-HideReadOnly * OFN_HIDEREADONLY) Or _
                 (flags And CLng(Not (OFN_ENABLEHOOK Or _
                                      OFN_ENABLETEMPLATE)))
        If Owner <> -1 Then .hwndOwner = Owner
        .lpstrInitialDir = InitDir
        .lpstrDefExt = DefaultExt
        .lpstrTitle = DlgTitle
        
        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
        s = s & vbNullChar & vbNullChar
        .lpstrFilter = s
        .nFilterIndex = FilterIndex
    
        ' 获取文件名
        lMax = MAX_PATH
        If (.flags And OFN_ALLOWMULTISELECT) = OFN_ALLOWMULTISELECT Then
          lMax = 8192
        End If
        s = Filename & String$(lMax - Len(Filename), 0)
        .lpstrFile = s
        .nMaxFile = lMax
        s = FileTitle & String$(lMax - Len(FileTitle), 0)
        .lpstrFileTitle = s
        .nMaxFileTitle = lMax
        ' 其它成员都设为0
        
        m_lApiReturn = GetOpenFileName(opfile)
        Select Case m_lApiReturn
        Case 1
            ' 成功
            fGetOpenFileName = True
            If (.flags And OFN_ALLOWMULTISELECT) = OFN_ALLOWMULTISELECT Then
                FileTitle = ""
                lMax = InStr(.lpstrFile, Chr$(0) & Chr$(0))
                If (lMax = 0) Then
                   Filename = StrZToStr(.lpstrFile)
                Else
                   Filename = Left$(.lpstrFile, lMax - 1)
                End If
            Else
                Filename = StrZToStr(.lpstrFile)
                FileTitle = StrZToStr(.lpstrFileTitle)
            End If
            flags = .flags
            FilterIndex = .nFilterIndex
            Filter = FilterLookup(.lpstrFilter, FilterIndex)
            If (.flags And OFN_READONLY) Then ReadOnly = True
        Case 0
            ' 取消
            fGetOpenFileName = False
            Filename = ""
            FileTitle = ""
            flags = 0
            FilterIndex = -1
            Filter = ""
        Case Else
            ' 错误
            m_lExtendedError = CommDlgExtendedError()
            fGetOpenFileName = False
            Filename = ""
            FileTitle = ""
            flags = 0
            FilterIndex = -1
            Filter = ""
        End Select
    End With
End FunctionPublic Function fGetSaveFileName(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 _
                           ) As Boolean
               
    On Error Resume Next
       Dim opfile As OPENFILENAME, s As String
   
       m_lApiReturn = 0
       m_lExtendedError = 0
    
    With opfile
        .lStructSize = Len(opfile)
        
        .flags = (-OverWritePrompt * OFN_OVERWRITEPROMPT) Or _
                 OFN_HIDEREADONLY Or _
                 (flags And CLng(Not (OFN_ENABLEHOOK Or _
                                      OFN_ENABLETEMPLATE)))
        If Owner <> -1 Then .hwndOwner = Owner
        .lpstrInitialDir = InitDir
        .lpstrDefExt = DefaultExt
        .lpstrTitle = DlgTitle
               
        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
        s = s & vbNullChar & vbNullChar
        .lpstrFilter = s
        .nFilterIndex = FilterIndex
    
        ' 获取文件名
        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
        ' 其它成员都设为0
        
        m_lApiReturn = GetSaveFileName(opfile)
        Select Case m_lApiReturn
        Case 1
            ' 成功
            fGetSaveFileName = True
            Filename = StrZToStr(.lpstrFile)
            FileTitle = StrZToStr(.lpstrFileTitle)
            flags = .flags
            FilterIndex = .nFilterIndex
            Filter = FilterLookup(.lpstrFilter, FilterIndex)
        Case 0
            ' 取消:
            fGetSaveFileName = False
            Filename = ""
            FileTitle = ""
            flags = 0
            FilterIndex = 0
            Filter = ""
        Case Else
            ' 错误:
            fGetSaveFileName = False
            m_lExtendedError = CommDlgExtendedError()
            Filename = ""
            FileTitle = ""
            flags = 0
            FilterIndex = 0
            Filter = ""
        End Select
    End With
End FunctionPrivate Function StrZToStr(s As String) As String
    StrZToStr = Left$(s, lstrlen(s))
End FunctionPrivate Function FilterLookup(ByVal sFilters As String, ByVal iCur As Long) As String
    On Error Resume Next
    Dim iStart As Long, iEnd As Long, s As String
    iStart = 1
    If sFilters = "" Then Exit Function
    Do
        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