?? mcommondialog.bas
字號:
PSD_INHUNDREDTHSOFMILLIMETERS = &H8
PSD_DISABLEMARGINS = &H10
PSD_DISABLEPRINTER = &H20
PSD_NoWarning = &H80
PSD_DISABLEORIENTATION = &H100
PSD_ReturnDefault = &H400
PSD_DISABLEPAPER = &H200
PSD_ShowHelp = &H800
PSD_EnablePageSetupHook = &H2000
PSD_EnablePageSetupTemplate = &H8000
PSD_EnablePageSetupTemplateHandle = &H20000
PSD_EnablePagePaintHook = &H40000
PSD_DisablePagePainting = &H80000
End Enum
Public Enum EPageSetupUnits
epsuInches
epsuMillimeters
End Enum
' Common dialog errors
Private Declare Function CommDlgExtendedError Lib "COMDLG32" () As Long
Public Enum EDialogError
CDERR_DIALOGFAILURE = &HFFFF
CDERR_GENERALCODES = &H0&
CDERR_STRUCTSIZE = &H1&
CDERR_INITIALIZATION = &H2&
CDERR_NOTEMPLATE = &H3&
CDERR_NOHINSTANCE = &H4&
CDERR_LOADSTRFAILURE = &H5&
CDERR_FINDRESFAILURE = &H6&
CDERR_LOADRESFAILURE = &H7&
CDERR_LOCKRESFAILURE = &H8&
CDERR_MEMALLOCFAILURE = &H9&
CDERR_MEMLOCKFAILURE = &HA&
CDERR_NOHOOK = &HB&
CDERR_REGISTERMSGFAIL = &HC&
PDERR_PRINTERCODES = &H1000&
PDERR_SETUPFAILURE = &H1001&
PDERR_PARSEFAILURE = &H1002&
PDERR_RETDEFFAILURE = &H1003&
PDERR_LOADDRVFAILURE = &H1004&
PDERR_GETDEVMODEFAIL = &H1005&
PDERR_INITFAILURE = &H1006&
PDERR_NODEVICES = &H1007&
PDERR_NODEFAULTPRN = &H1008&
PDERR_DNDMMISMATCH = &H1009&
PDERR_CREATEICFAILURE = &H100A&
PDERR_PRINTERNOTFOUND = &H100B&
PDERR_DEFAULTDIFFERENT = &H100C&
CFERR_CHOOSEFONTCODES = &H2000&
CFERR_NOFONTS = &H2001&
CFERR_MAXLESSTHANMIN = &H2002&
FNERR_FILENAMECODES = &H3000&
FNERR_SUBCLASSFAILURE = &H3001&
FNERR_INVALIDFILENAME = &H3002&
FNERR_BUFFERTOOSMALL = &H3003&
CCERR_CHOOSECOLORCODES = &H5000&
End Enum
' Hook and notification support:
Private Type NMHDR
hwndFrom As Long
idfrom As Long
code As Long
End Type
'// Structure used for all file based OpenFileName notifications
Private Type OFNOTIFY
hdr As NMHDR
lpOFN As Long ' Long pointer to OFN structure
pszFile As String '; // May be NULL
End Type
'// Structure used for all object based OpenFileName notifications
Private Type OFNOTIFYEX
hdr As NMHDR
lpOFN As Long ' Long pointer to OFN structure
psf As Long
LPVOID As Long '// May be NULL
End Type
Private Type OFNOTIFYshort
hdr As NMHDR
lpOFN As Long
End Type
' Messages:
Private Const WM_DESTROY = &H2
Private Const WM_NOTIFY = &H4E
Private Const WM_NCDESTROY = &H82
Private Const WM_GETDLGCODE = &H87
Private Const WM_INITDIALOG = &H110
Private Const WM_COMMAND = &H111
Private Const WM_USER = &H400
' Notification codes:
Private Const H_MAX As Long = &HFFFF + 1
Private Const CDN_FIRST = (H_MAX - 601)
Private Const CDN_LAST = (H_MAX - 699)
'// Notifications when Open or Save dialog status changes
Private Const CDN_INITDONE = (CDN_FIRST - &H0)
Private Const CDN_SELCHANGE = (CDN_FIRST - &H1)
Private Const CDN_FOLDERCHANGE = (CDN_FIRST - &H2)
Private Const CDN_SHAREVIOLATION = (CDN_FIRST - &H3)
Private Const CDN_HELP = (CDN_FIRST - &H4)
Private Const CDN_FILEOK = (CDN_FIRST - &H5)
Private Const CDN_TYPECHANGE = (CDN_FIRST - &H6)
Private Const CDN_INCLUDEITEM = (CDN_FIRST - &H7)
' Messages which can be sent to the standard dialog elements
Private Const CDM_FIRST = (WM_USER + 100)
Private Const CDM_LAST = (WM_USER + 200)
Private Const CDM_GETSPEC = (CDM_FIRST + &H0)
Private Const CDM_GETFILEPATH = (CDM_FIRST + &H1)
Private Const CDM_GETFOLDERPATH = (CDM_FIRST + &H2)
Private Const CDM_GETFOLDERIDLIST = (CDM_FIRST + &H3)
Private Const CDM_SETCONTROLTEXT = (CDM_FIRST + &H4)
Private Const CDM_HIDECONTROL = (CDM_FIRST + &H5)
Private Const CDM_SETDEFEXT = (CDM_FIRST + &H6)
' IDs for standard common dialog controls
Private Const ID_OPEN = &H1 'Open or Save button
Private Const ID_CANCEL = &H2 'Cancel Button
Private Const ID_HELP = &H40E 'Help Button
Private Const ID_READONLY = &H410 'Read-only check box
Private Const ID_FILETYPELABEL = &H441 'Files of type label
Private Const ID_FILELABEL = &H442 'File name label
Private Const ID_FOLDERLABEL = &H443 'Look in label
Private Const ID_LIST = &H461 'Parent of file list
Private Const ID_FORMAT = &H470 'File type combo box
Private Const ID_FOLDER = &H471 'Folder combo box
Private Const ID_FILETEXT = &H480 'File name text box
Private Const DWL_MSGRESULT = 0
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
' ==========================================================================
' Implementation:
' ==========================================================================
' Array of custom colors lasts for life of app
Private alCustom(0 To 15) As Long, fNotFirst As Boolean
Public Enum EPrintRange
eprAll
eprPageNumbers
eprSelection
End Enum
Private m_lApiReturn As Long
Private m_lExtendedError As Long
Private m_dvmode As DevMode
Private m_oEventSink As Object
Public Function DialogHook(ByVal hDlg As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long)
Dim tNMH As NMHDR
Dim tOFNs As OFNOTIFYshort
Dim tOF As OPENFILENAME
If Not (m_oEventSink Is Nothing) Then
Select Case msg
Case WM_INITDIALOG
DialogHook = m_oEventSink.InitDialog(hDlg)
Case WM_NOTIFY
CopyMemory tNMH, ByVal lParam, Len(tNMH)
Select Case tNMH.code
Case CDN_SELCHANGE
' Changed selected file:
DialogHook = m_oEventSink.FileChange(hDlg)
Case CDN_FOLDERCHANGE
' Changed folder:
DialogHook = m_oEventSink.FolderChange(hDlg)
Case CDN_FILEOK
' Clicked OK:
If Not m_oEventSink.ConfirmOK() Then
SetWindowLong hDlg, DWL_MSGRESULT, 1
DialogHook = 1
Else
SetWindowLong hDlg, DWL_MSGRESULT, 0
End If
Case CDN_HELP
' Help clicked
Case CDN_TYPECHANGE
DialogHook = m_oEventSink.TypeChange(hDlg)
Case CDN_INCLUDEITEM
' Hmmm
End Select
Case WM_COMMAND
m_oEventSink.WMCommand hDlg, wParam, lParam
Case WM_DESTROY
Debug.Print "WM_DESTROY"
m_oEventSink.DialogClose
End Select
End If
End Function
Public Property Get APIReturn() As Long
'return object's APIReturn property
APIReturn = m_lApiReturn
End Property
Public Property Get ExtendedError() As Long
'return object's ExtendedError property
ExtendedError = m_lExtendedError
End Property
Private Sub Class_Initialize()
#If fComponent Then
InitColors
#End If
End Sub
Function VBGetOpenFileName2(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, _
Optional Hook As Boolean = False, _
Optional hInstance As Long = 0, _
Optional TemplateName As Long = 0 _
) As Boolean
Dim opfile As OPENFILENAME, s As String, afFlags As Long
m_lApiReturn = 0
m_lExtendedError = 0
With opfile
.lStructSize = Len(opfile)
' Add in specific flags and strip out non-VB flags
.flags = (-FileMustExist * OFN_FILEMUSTEXIST) Or _
(-MultiSelect * OFN_ALLOWMULTISELECT) Or _
(-ReadOnly * OFN_READONLY) Or _
(-HideReadOnly * 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_ALLOWMULTISELECT) = OFN_ALLOWMULTISELECT Then
.flags = .flags Or OFN_EXPLORER
End If
If flags And OFN_ENABLETEMPLATE Then
If hInstance > 0 Then
.flags = .flags Or OFN_ENABLETEMPLATE
.hInstance = hInstance
.lpTemplateName = TemplateName
End If
End If
' To make Windows-style filter, replace | and : with nulls
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 = s
.nFilterIndex = FilterIndex
' Pad file and file title buffers to maximum path
If (.flags And OFN_ALLOWMULTISELECT) = OFN_ALLOWMULTISELECT Then
s = Filename & String$(8192 - Len(Filename), 0)
.lpstrFile = s
.nMaxFile = 8192
s = FileTitle & String$(8192 - Len(FileTitle), 0)
.lpstrFileTitle = s
.nMaxFileTitle = 8192
Else
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
End If
' All other fields set to zero
m_lApiReturn = GetOpenFileName(opfile)
Set m_oEventSink = Nothing
Select Case m_lApiReturn
Case 1
' Success
VBGetOpenFileName2 = True
If (.flags And OFN_ALLOWMULTISELECT) = OFN_ALLOWMULTISELECT Then
Filename = .lpstrFile
Else
Filename = StrZToStr(.lpstrFile)
FileTitle = StrZToStr(.lpstrFileTitle)
End If
flags = .flags
' Return the filter index
FilterIndex = .nFilterIndex
' Look up the filter the user selected and return that
Filter = FilterLookup(.lpstrFilter, FilterIndex)
If (.flags And OFN_READONLY) Then ReadOnly = True
Case 0
' Cancelled
VBGetOpenFileName2 = False
Filename = ""
FileTitle = ""
flags = 0
FilterIndex = -1
Filter = ""
Case Else
' Extended error
m_lExtendedError = CommDlgExtendedError()
VBGetOpenFileName2 = False
Filename = ""
FileTitle = ""
flags = 0
FilterIndex = -1
Filter = ""
End Select
Set m_oEventSink = Nothing
End With
End Function
Function VBGetOpenFileName(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, _
Optional Hook As Boolean = False _
) As Boolean
flags = flags And Not OFN_ENABLETEMPLATE
VBGetOpenFileName = VBGetOpenFileName2( _
Filename, FileTitle, FileMustExist, MultiSelect, _
ReadOnly, HideReadOnly, Filter, FilterIndex, InitDir, DlgTitle, _
DefaultExt, Owner, flags, Hook)
End Function
Private Function lHookAddress(lPtr As Long) As Long
'Debug.Print lPtr
lHookAddress = lPtr
End Function
Private Function StrZToStr(s As String) As String
?? 快捷鍵說明
復(fù)制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -