用API调出保存文件对话框时，若用户选了一个已存在的文件，如何弹出"文件已存在，要覆盖吗"的消息框?

2001-12-19 12:55:19 411 阅读 AI 写同款 · GEO 优化AI 选题数据监测一键分发 ›

Keil转STM32CubeIDE工程移植问题记录从Keil工程移植到STM32CubeIDE过程中会出现大量的编译错误以及相关问题，在此记录以及更新阅读详情

...全文

EmberZNet学习-新建工程碰到问题及解决过程刚接触EFR32MG21两天，第一次用Simplicity Studio，用demo建工程的时候就出了问题，现在记录一下解决问题的过程。直接用Z3Switch新建工程，Board为None，Part选择EFR32MG21A010F768IM32。建立工程后，在xxx.isc右上角点击Generate，之后选中工程，点击Build。会发生PTI报错如下。（我没有用官方的开发板，官方的开发板Board是有型号的而不是我们这些穷鬼的None，用官方板子之间建demo用demo是木有问题的。）去掉PTI勾选，阅读详情

MonkeyLin

API 1,488 成员 23,270 内容

+ 关注 + 加入社区

切换为时间正序

uguess 2001-12-19

打赏
举报

Private Const OFN_OVERWRITEPROMPT = &H2

设定这个标志就可以啦。

lonaerd 2001-12-19

打赏
举报

用filesystemobject来判断，很容易的
Dim f As FileSystemObject
Dim S As TextStream
Set f = CreateObject("Scripting.FileSystemObject")
If f.FileExists(me.commondlog1.filename) = True Then
msgbox "该文件已经存在"
end if

hz1101 2001-12-19

打赏
举报

太长太繁！！！！！

foxruo 2001-12-19

打赏
举报

CommonDialog1.Flags = &H2&

lovemore 2001-12-19

打赏
举报

通过设置commondialog的falg属性，只须CommonDialog1.Flags = &H2& 即可搞定。。

请看，以下资料来源于MSDN..
'-------------------------------------------------------------
Flags 属性（“打开”、“另存为”对话框）

为“打开”和“另存为”对话框返回或设置选项。

语法

object.Flags [= value]

Flags 属性语法有下列部分：

部分描述
object 对象表达式，其值是“应用于”列表中的对象。
value 如“设置值”中所描述，是为“打开”和“另存为”对话框指定选项的常数或值。

设置值

Value 的设置值是：

常数值描述
cdlOFNAllowMultiselect &H200 它指定文件名列表框允许多重选择。
运行时，通过按 SHIFT 键以及使用 UP ARROW 和 DOWN ARROW 键可选择多个文件。作完此操作后，FileName 属性就返回一个包含全部所选文件名的字符串。串中各文件名用空格隔开。

cdlOFNCreatePrompt &H2000 当文件不存在时对话框要提示创建文件。该标志自动设置 cdlOFNPathMustExist 和 cdlOFNFileMustExist 标志。
cdlOFNExplorer &H80000 它使用类似资源管理器的打开一个文件的对话框模板。适用于 Windows 95 和 Windows NT 4.0。
CdlOFNExtensionDifferent &H400 它指示返回的文件扩展名与 DefaultExt 属性指定的扩展名不一致。如果 DefaultExt 属性是 Null，或者扩展相匹配，或者没有扩展时，此标志不设置。当关闭对话框时，可以检查这个标志的值。
cdlOFNFileMustExist &H1000 它指定只能输入文件名文本框已经存在的文件名。如果该标志被设置，则当用户输入非法的文件名时，要显示一个警告。该标志自动设置 cdlOFNPathMustExist 标志。
cdlOFNHelpButton &H10 使对话框显示帮助按钮。
cdlOFNHideReadOnly &H4 隐藏只读复选框。
cdlOFNLongNames &H200000 使用长文件名。
cdlOFNNoChangeDir &H8 强制对话框将对话框打开时的目录置成当前目录。
CdlOFNNoDereferenceLinks &H100000 不要间接引用外壳链接（也称作快捷方式）。缺省时，选取外壳链接会引起它被外壳间接引用。
cdlOFNNoLongNames &H40000 无长文件名。
CdlOFNNoReadOnlyReturn &H8000 它指定返回的文件不能具有只读属性，也不能在写保护目录下面。
cdlOFNNoValidate &H100 它指定公共对话框允许返回的文件名中含有非法字符。
cdlOFNOverwritePrompt &H2 使“另存为”对话框当选择的文件已经存在时应产生一个信息框，用户必须确认是否覆盖该文件。
cdlOFNPathMustExist &H800 它指定只能输入有效路径。如果设置该标志，输入非法路径时，应显示一个警告信息。
cdlOFNReadOnly &H1 建立对话框时，只读复选框初始化为选定。该标志也指示对话框关闭时只读复选框的状态。
cdlOFNShareAware &H4000 它指定忽略共享冲突错误。

说明

cdlOFNExplorer 和 cdlOFNNoDereferenceLinks 标志适用于 Windows 95 和 Windows NT 4.0。Windows 95 中 cdlOFNExplorer 的公共对话框使用字符作为分隔符；而在没有 Windows 95 外壳的 Windows NT 的早期版本中，多重选择是使用空格作为分隔符（固而不能支持长文件名）。

无论是在 Windows NT 4.0 还是在 Windows 95 中，如果不选取 cdlOFNAllowMultiselect 标志，cdlOFNExplorer 和 cdlOFNLongNames 标志均没有意义，并且实际上是缺省值。

无论是在 Windows NT 4.0 还是在 Windows 95 中，如果 cdlOFNAllowMultiselect 标志被单独使用，都不能支持长文件名。这是因为多重文件名要复现空格分隔符，而长文件名也可能包括空格符。在 Windows NT 3.5 中，无法避免这种情况。如果使用 cdlOFNAllowMultiselect，就不能看到长文件名。如果在 Windows 95 中添加 cdlOFNExplorer 标志，就可以既能文件多选，又能看到长文件名。但是，这些文件名显现空字符分隔符，而不是空格分隔符隔开。因此，cdlOFNAllowMultiselect 和 cdlOFNExplorer 一起使用时，在 Windows 95 和 Windows NT 4.0 中需要不同的文件名所得结果的语法分析。

这些常数在对象浏览器中的 Microsoft CommonDialog 控件 (MSComDlg) 对象库中列出。

也可以定义所选择的标志。应使用启动窗体声明部分的 Const 关键字来定义想使用的标志。例如：

Const ReadOnly = &H00000001&
Const Effects = &H00000100&
CommonDialog1.Flags = &H10& Or &H200&

将所需常数值能相加产生同样的结果。下例与上例等效：

CommonDialog1.Flags = &H210&

数据类型

Long

tingquan 2001-12-19

打赏
举报

这个问题我也碰到过,不过我是用弹出窗口来实现的,也不是很繁,还可以通过弹出对话框来实现.
searchFileName=Dir(strFileName, 7) 'strfileName是要保存的文件名,如果searchFileName不为空则表示文件存在,通过判断运行下面的程序
rstMsg=MsgBox("This file is existed,do u want to cover it?", vbYesNo,"Error")
if rstMsg=vbYes then do something'覆盖,不覆盖就继续

sxmzmxh 2001-12-19

打赏
举报

to Bardo(巴顿)，你要干什么

Bardo 2001-12-19

打赏
举报

Attribute VB_Name = "basCommonDialog"
Option Explicit

Type RECT
left As Long
top As Long
Right As Long
Bottom As Long
End Type

Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function GetCurrentThreadId Lib "KERNEL32" () As Long
Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Const GWL_HINSTANCE = (-6)
Const SWP_NOSIZE = &H1
Const SWP_NOZORDER = &H4
Const SWP_NOACTIVATE = &H10
Const HCBT_ACTIVATE = 5
Const WH_CBT = 5

Dim hHook As Long

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLORS) As Long
Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Declare Function GetShortPathName Lib "KERNEL32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONTS) As Long
Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLGS) As Long

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long

Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_ENABLEHOOK = &H20
Public Const OFN_ENABLETEMPLATE = &H40
Public Const OFN_ENABLETEMPLATEHANDLE = &H80
Public Const OFN_EXPLORER = &H80000
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_LONGNAMES = &H200000
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_NOLONGNAMES = &H40000
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOTESTFILECREATE = &H10000
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_READONLY = &H1
Public Const OFN_SHAREAWARE = &H4000
Public Const OFN_SHAREFALLTHROUGH = 2
Public Const OFN_SHAREWARN = 0
Public Const OFN_SHARENOWARN = 1
Public Const OFN_SHOWHELP = &H10
Public Const OFS_MAXPATHNAME = 256

Public Const LF_FACESIZE = 32

'OFS_FILE_OPEN_FLAGS and OFS_FILE_SAVE_FLAGS below
'are mine to save long statements; they're not
'a standard Win32 type.
Public Const OFS_FILE_OPEN_FLAGS = OFN_EXPLORER Or OFN_LONGNAMES Or OFN_CREATEPROMPT Or OFN_NODEREFERENCELINKS Or OFN_HIDEREADONLY Or OFN_ALLOWMULTISELECT
Public Const OFS_FILE_SAVE_FLAGS = OFN_EXPLORER Or OFN_LONGNAMES Or OFN_OVERWRITEPROMPT Or OFN_HIDEREADONLY

Public Type OPENFILENAME
nStructSize As Long
hwndOwner As Long
hInstance As Long
sFilter As String
sCustomFilter As String
nCustFilterSize As Long
nFilterIndex As Long
sFile As String
nFileSize As Long
sFileTitle As String
nTitleSize As Long
sInitDir As String
sDlgTitle As String
flags As Long
nFileOffset As Integer
nFileExt As Integer
sDefFileExt As String
nCustDataSize As Long
fnHook As Long
sTemplateName As String
End Type

Type NMHDR
hwndFrom As Long
idfrom As Long
code As Long
End Type

Type OFNOTIFY
hdr As NMHDR
lpOFN As OPENFILENAME
pszFile As String ' May be NULL
End Type

Type CHOOSECOLORS
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

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(LF_FACESIZE) As Byte
End Type

Public Type CHOOSEFONTS
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
lpszStyle As String ' return the style field here
nFontType As Integer ' same value reported to the EnumFonts
MISSING_ALIGNMENT As Integer
nSizeMin As Long ' minimum pt size allowed &
nSizeMax As Long ' max pt size allowed if
End Type

Public Const CC_RGBINIT = &H1
Public Const CC_FULLOPEN = &H2
Public Const CC_PREVENTFULLOPEN = &H4
Public Const CC_SHOWHELP = &H8
Public Const CC_ENABLEHOOK = &H10
Public Const CC_ENABLETEMPLATE = &H20
Public Const CC_ENABLETEMPLATEHANDLE = &H40
Public Const CC_SOLIDCOLOR = &H80
Public Const CC_ANYCOLOR = &H100

Public Const COLOR_FLAGS = CC_FULLOPEN Or CC_ANYCOLOR Or CC_RGBINIT

Public Const CF_SCREENFONTS = &H1
Public Const CF_PRINTERFONTS = &H2
Public Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Public Const CF_SHOWHELP = &H4&
Public Const CF_ENABLEHOOK = &H8&
Public Const CF_ENABLETEMPLATE = &H10&
Public Const CF_ENABLETEMPLATEHANDLE = &H20&
Public Const CF_INITTOLOGFONTSTRUCT = &H40&
Public Const CF_USESTYLE = &H80&
Public Const CF_EFFECTS = &H100&
Public Const CF_APPLY = &H200&
Public Const CF_ANSIONLY = &H400&
Public Const CF_SCRIPTSONLY = CF_ANSIONLY
Public Const CF_NOVECTORFONTS = &H800&
Public Const CF_NOOEMFONTS = CF_NOVECTORFONTS
Public Const CF_NOSIMULATIONS = &H1000&
Public Const CF_LIMITSIZE = &H2000&
Public Const CF_FIXEDPITCHONLY = &H4000&
Public Const CF_WYSIWYG = &H8000 ' must also have CF_SCREENFONTS CF_PRINTERFONTS
Public Const CF_FORCEFONTEXIST = &H10000
Public Const CF_SCALABLEONLY = &H20000
Public Const CF_TTONLY = &H40000
Public Const CF_NOFACESEL = &H80000
Public Const CF_NOSTYLESEL = &H100000
Public Const CF_NOSIZESEL = &H200000
Public Const CF_SELECTSCRIPT = &H400000
Public Const CF_NOSCRIPTSEL = &H800000
Public Const CF_NOVERTFONTS = &H1000000

Public Const SIMULATED_FONTTYPE = &H8000
Public Const PRINTER_FONTTYPE = &H4000
Public Const SCREEN_FONTTYPE = &H2000
Public Const BOLD_FONTTYPE = &H100
Public Const ITALIC_FONTTYPE = &H200
Public Const REGULAR_FONTTYPE = &H400

Public Const LBSELCHSTRING = "commdlg_LBSelChangedNotify"
Public Const SHAREVISTRING = "commdlg_ShareViolation"
Public Const FILEOKSTRING = "commdlg_FileNameOK"
Public Const COLOROKSTRING = "commdlg_ColorOK"
Public Const SETRGBSTRING = "commdlg_SetRGBColor"
Public Const HELPMSGSTRING = "commdlg_help"
Public Const FINDMSGSTRING = "commdlg_FindReplace"

Public Const CD_LBSELNOITEMS = -1
Public Const CD_LBSELCHANGE = 0
Public Const CD_LBSELSUB = 1
Public Const CD_LBSELADD = 2

Type PRINTDLGS
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

Public Const PD_ALLPAGES = &H0
Public Const PD_SELECTION = &H1
Public Const PD_PAGENUMS = &H2
Public Const PD_NOSELECTION = &H4
Public Const PD_NOPAGENUMS = &H8
Public Const PD_COLLATE = &H10
Public Const PD_PRINTTOFILE = &H20
Public Const PD_PRINTSETUP = &H40
Public Const PD_NOWARNING = &H80
Public Const PD_RETURNDC = &H100
Public Const PD_RETURNIC = &H200
Public Const PD_RETURNDEFAULT = &H400
Public Const PD_SHOWHELP = &H800
Public Const PD_ENABLEPRINTHOOK = &H1000
Public Const PD_ENABLESETUPHOOK = &H2000
Public Const PD_ENABLEPRINTTEMPLATE = &H4000
Public Const PD_ENABLESETUPTEMPLATE = &H8000
Public Const PD_ENABLEPRINTTEMPLATEHANDLE = &H10000
Public Const PD_ENABLESETUPTEMPLATEHANDLE = &H20000
Public Const PD_USEDEVMODECOPIES = &H40000
Public Const PD_USEDEVMODECOPIESANDCOLLATE = &H40000
Public Const PD_DISABLEPRINTTOFILE = &H80000
Public Const PD_HIDEPRINTTOFILE = &H100000
Public Const PD_NONETWORKBUTTON = &H200000

Type DEVNAMES
wDriverOffset As Integer
wDeviceOffset As Integer
wOutputOffset As Integer
wDefault As Integer
End Type

Public Const DN_DEFAULTPRN = &H1

Public Type SelectedFile
nFilesSelected As Integer
sFiles() As String
sLastDirectory As String
bCanceled As Boolean
End Type

Public Type SelectedColor
oSelectedColor As OLE_COLOR
bCanceled As Boolean
End Type

Public Type SelectedFont
sSelectedFont As String
bCanceled As Boolean
bBold As Boolean
bItalic As Boolean
nSize As Integer
bUnderline As Boolean
bStrikeOut As Boolean
lColor As Long
sFaceName As String
End Type

Public FileDialog As OPENFILENAME
Public ColorDialog As CHOOSECOLORS
Public FontDialog As CHOOSEFONTS
Public PrintDialog As PRINTDLGS
Dim parenthWnd As Long

Public Function ShowOpen(ByVal hwnd As Long, Optional ByVal centerForm As Boolean = True) As SelectedFile
Dim ret As Long
Dim Count As Integer
Dim fileNameHolder As String
Dim LastCharacter As Integer
Dim NewCharacter As Integer
Dim tempFiles(1 To 200) As String
Dim hInst As Long
Dim Thread As Long

parenthWnd = hwnd
FileDialog.nStructSize = Len(FileDialog)
FileDialog.hwndOwner = hwnd
FileDialog.sFileTitle = Space$(2048)
FileDialog.nTitleSize = Len(FileDialog.sFileTitle)
FileDialog.sFile = FileDialog.sFile & Space$(2047) & Chr$(0)
FileDialog.nFileSize = Len(FileDialog.sFile)

'If FileDialog.flags = 0 Then
FileDialog.flags = OFS_FILE_OPEN_FLAGS
'End If

'Set up the CBT hook
hInst = GetWindowLong(hwnd, GWL_HINSTANCE)
Thread = GetCurrentThreadId()
If centerForm = True Then
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterForm, hInst, Thread)
Else
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterScreen, hInst, Thread)
End If

ret = GetOpenFileName(FileDialog)

If ret Then
If Trim$(FileDialog.sFileTitle) = "" Then
LastCharacter = 0
Count = 0
While ShowOpen.nFilesSelected = 0
NewCharacter = InStr(LastCharacter + 1, FileDialog.sFile, Chr$(0), vbTextCompare)
If Count > 0 Then
tempFiles(Count) = Mid(FileDialog.sFile, LastCharacter + 1, NewCharacter - LastCharacter - 1)
Else
ShowOpen.sLastDirectory = Mid(FileDialog.sFile, LastCharacter + 1, NewCharacter - LastCharacter - 1)
End If
Count = Count + 1
If InStr(NewCharacter + 1, FileDialog.sFile, Chr$(0), vbTextCompare) = InStr(NewCharacter + 1, FileDialog.sFile, Chr$(0) & Chr$(0), vbTextCompare) Then
tempFiles(Count) = Mid(FileDialog.sFile, NewCharacter + 1, InStr(NewCharacter + 1, FileDialog.sFile, Chr$(0) & Chr$(0), vbTextCompare) - NewCharacter - 1)
ShowOpen.nFilesSelected = Count
End If
LastCharacter = NewCharacter
Wend
ReDim ShowOpen.sFiles(1 To ShowOpen.nFilesSelected)
For Count = 1 To ShowOpen.nFilesSelected
ShowOpen.sFiles(Count) = tempFiles(Count)
Next
Else
ReDim ShowOpen.sFiles(1 To 1)
ShowOpen.sLastDirectory = left$(FileDialog.sFile, FileDialog.nFileOffset)
ShowOpen.nFilesSelected = 1
ShowOpen.sFiles(1) = Mid(FileDialog.sFile, FileDialog.nFileOffset + 1, InStr(1, FileDialog.sFile, Chr$(0), vbTextCompare) - FileDialog.nFileOffset - 1)
End If
ShowOpen.bCanceled = False
Exit Function
Else
ShowOpen.sLastDirectory = ""
ShowOpen.nFilesSelected = 0
ShowOpen.bCanceled = True
Erase ShowOpen.sFiles
Exit Function
End If
End Function

Public Function ShowSave(ByVal hwnd As Long, Optional ByVal centerForm As Boolean = True) As SelectedFile
Dim ret As Long
Dim hInst As Long
Dim Thread As Long

parenthWnd = hwnd
FileDialog.nStructSize = Len(FileDialog)
FileDialog.hwndOwner = hwnd
FileDialog.sFileTitle = Space$(2048)
FileDialog.nTitleSize = Len(FileDialog.sFileTitle)
If FileDialog.sFile = "" Then
FileDialog.sFile = Space$(2047) & Chr$(0)
ElseIf Right(FileDialog.sFile, 1) <> Chr$(0) Then
FileDialog.sFile = FileDialog.sFile & Space$(2047 - Len(FileDialog.sFile)) & Chr$(0)
End If
FileDialog.nFileSize = Len(FileDialog.sFile)

If FileDialog.flags = 0 Then
FileDialog.flags = OFS_FILE_SAVE_FLAGS
End If

'Set up the CBT hook
hInst = GetWindowLong(hwnd, GWL_HINSTANCE)
Thread = GetCurrentThreadId()
If centerForm = True Then
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterForm, hInst, Thread)
Else
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterScreen, hInst, Thread)
End If

ret = GetSaveFileName(FileDialog)
ReDim ShowSave.sFiles(1)

If ret Then
ShowSave.sLastDirectory = left$(FileDialog.sFile, FileDialog.nFileOffset)
ShowSave.nFilesSelected = 1
ShowSave.sFiles(1) = Mid(FileDialog.sFile, FileDialog.nFileOffset + 1, InStr(1, FileDialog.sFile, Chr$(0), vbTextCompare) - FileDialog.nFileOffset - 1)
ShowSave.bCanceled = False
Exit Function
Else
ShowSave.sLastDirectory = ""
ShowSave.nFilesSelected = 0
ShowSave.bCanceled = True
Erase ShowSave.sFiles
Exit Function
End If
End Function

Public Function ShowColor(ByVal hwnd As Long, Optional ByVal centerForm As Boolean = True) As SelectedColor
Dim customcolors() As Byte ' dynamic (resizable) array
Dim i As Integer
Dim ret As Long
Dim hInst As Long
Dim Thread As Long

parenthWnd = hwnd
If ColorDialog.lpCustColors = "" Then
ReDim customcolors(0 To 16 * 4 - 1) As Byte 'resize the array

For i = LBound(customcolors) To UBound(customcolors)
customcolors(i) = 254 ' sets all custom colors to white
Next i

ColorDialog.lpCustColors = StrConv(customcolors, vbUnicode) ' convert array
End If

ColorDialog.hwndOwner = hwnd
ColorDialog.lStructSize = Len(ColorDialog)
ColorDialog.flags = COLOR_FLAGS

'Set up the CBT hook
hInst = GetWindowLong(hwnd, GWL_HINSTANCE)
Thread = GetCurrentThreadId()
If centerForm = True Then
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterForm, hInst, Thread)
Else
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterScreen, hInst, Thread)
End If

ret = ChooseColor(ColorDialog)
If ret Then
ShowColor.bCanceled = False
ShowColor.oSelectedColor = ColorDialog.rgbResult
Exit Function
Else
ShowColor.bCanceled = True
ShowColor.oSelectedColor = &H0&
Exit Function
End If
End Function

Public Function ShowFont(ByVal hwnd As Long, ByVal startingFontName As String, Optional ByVal centerForm As Boolean = True) As SelectedFont
Dim ret As Long
Dim lfLogFont As LOGFONT
Dim hInst As Long
Dim Thread As Long
Dim i As Integer

parenthWnd = hwnd
FontDialog.nSizeMax = 0
FontDialog.nSizeMin = 0
FontDialog.nFontType = Screen.FontCount
FontDialog.hwndOwner = hwnd
FontDialog.hDC = 0
FontDialog.lpfnHook = 0
FontDialog.lCustData = 0
FontDialog.lpLogFont = VarPtr(lfLogFont)
FontDialog.iPointSize = 10
FontDialog.lpTemplateName = Space$(2048)
FontDialog.rgbColors = RGB(0, 255, 255)
FontDialog.lStructSize = Len(FontDialog)

If FontDialog.flags = 0 Then
FontDialog.flags = CF_SCREENFONTS Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT 'Or CF_EFFECTS
End If

For i = 0 To Len(startingFontName) - 1
lfLogFont.lfFaceName(i) = Asc(Mid(startingFontName, i + 1, 1))
Next

'Set up the CBT hook
hInst = GetWindowLong(hwnd, GWL_HINSTANCE)
Thread = GetCurrentThreadId()
If centerForm = True Then
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterForm, hInst, Thread)
Else
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterScreen, hInst, Thread)
End If

ret = ChooseFont(FontDialog)

If ret Then
ShowFont.bCanceled = False
ShowFont.bBold = IIf(lfLogFont.lfWeight > 400, 1, 0)
ShowFont.bItalic = lfLogFont.lfItalic
ShowFont.bStrikeOut = lfLogFont.lfStrikeOut
ShowFont.bUnderline = lfLogFont.lfUnderline
ShowFont.lColor = FontDialog.rgbColors
ShowFont.nSize = FontDialog.iPointSize / 10
For i = 0 To 31
ShowFont.sSelectedFont = ShowFont.sSelectedFont + Chr(lfLogFont.lfFaceName(i))
Next

ShowFont.sSelectedFont = Mid(ShowFont.sSelectedFont, 1, InStr(1, ShowFont.sSelectedFont, Chr(0)) - 1)
Exit Function
Else
ShowFont.bCanceled = True
Exit Function
End If
End Function
Public Function ShowPrinter(ByVal hwnd As Long, Optional ByVal centerForm As Boolean = True) As Long
Dim hInst As Long
Dim Thread As Long

parenthWnd = hwnd
PrintDialog.hwndOwner = hwnd
PrintDialog.lStructSize = Len(PrintDialog)

'Set up the CBT hook
hInst = GetWindowLong(hwnd, GWL_HINSTANCE)
Thread = GetCurrentThreadId()
If centerForm = True Then
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterForm, hInst, Thread)
Else
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterScreen, hInst, Thread)
End If

ShowPrinter = PrintDlg(PrintDialog)
End Function
Private Function WinProcCenterScreen(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim rectForm As RECT, rectMsg As RECT
Dim x As Long, y As Long
If lMsg = HCBT_ACTIVATE Then
'Show the MsgBox at a fixed location (0,0)
GetWindowRect wParam, rectMsg
x = Screen.Width / Screen.TwipsPerPixelX / 2 - (rectMsg.Right - rectMsg.left) / 2
y = Screen.Height / Screen.TwipsPerPixelY / 2 - (rectMsg.Bottom - rectMsg.top) / 2
Debug.Print "Screen " & Screen.Height / 2
Debug.Print "MsgBox " & (rectMsg.Right - rectMsg.left) / 2
SetWindowPos wParam, 0, x, y, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE
'Release the CBT hook
UnhookWindowsHookEx hHook
End If
WinProcCenterScreen = False
End Function

Private Function WinProcCenterForm(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim rectForm As RECT, rectMsg As RECT
Dim x As Long, y As Long
'On HCBT_ACTIVATE, show the MsgBox centered over Form1
If lMsg = HCBT_ACTIVATE Then
'Get the coordinates of the form and the message box so that
'you can determine where the center of the form is located
GetWindowRect parenthWnd, rectForm
GetWindowRect wParam, rectMsg
x = (rectForm.left + (rectForm.Right - rectForm.left) / 2) - ((rectMsg.Right - rectMsg.left) / 2)
y = (rectForm.top + (rectForm.Bottom - rectForm.top) / 2) - ((rectMsg.Bottom - rectMsg.top) / 2)
'Position the msgbox
SetWindowPos wParam, 0, x, y, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE
'Release the CBT hook
UnhookWindowsHookEx hHook
End If
WinProcCenterForm = False
End Function

Public Function DetermineDirectory(inputString As String) As String
Dim pos As Integer
pos = InStrRev(inputString, "\", , vbTextCompare)
DetermineDirectory = Mid(inputString, 1, pos)
End Function
Public Function DetermineFilename(inputString As String) As String
Dim pos As Integer
If InStr(1, inputString, "\") = 0 Then
DetermineFilename = inputString
Else
pos = InStrRev(inputString, "\", , vbTextCompare)
DetermineFilename = Mid(inputString, pos + 1, Len(inputString) - pos)
End If
End Function

Attribute VB_Name = "basMessageBox"
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
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function GetCurrentThreadId Lib "KERNEL32" () As Long
Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Const GWL_HINSTANCE = (-6)
Const SWP_NOSIZE = &H1
Const SWP_NOZORDER = &H4
Const SWP_NOACTIVATE = &H10
Const HCBT_ACTIVATE = 5
Const WH_CBT = 5

Type RECT
left As Long
top As Long
Right As Long
Bottom As Long
End Type

Dim hHook As Long
Dim parenthWnd As Long

Public Function MessageBox(ByVal hwnd As Long, ByVal Prompt As String, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, Optional ByVal Title As String = "", Optional ByVal HelpFile As String, Optional ByVal Context, Optional ByVal centerForm As Boolean = True) As VbMsgBoxResult
Dim ret As Long
Dim hInst As Long
Dim Thread As Long
'Set up the CBT hook
parenthWnd = hwnd
hInst = GetWindowLong(hwnd, GWL_HINSTANCE)
Thread = GetCurrentThreadId()
If centerForm = True Then
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterForm, hInst, Thread)
Else
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterScreen, hInst, Thread)
End If

ret = MessageBoxEx(hwnd, Prompt, Title, Buttons, 0)
MessageBox = ret
End Function

Private Function WinProcCenterScreen(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim rectForm As RECT, rectMsg As RECT
Dim x As Long, y As Long
If lMsg = HCBT_ACTIVATE Then
'Show the MsgBox at a fixed location (0,0)
GetWindowRect wParam, rectMsg
x = Screen.Width / Screen.TwipsPerPixelX / 2 - (rectMsg.Right - rectMsg.left) / 2
y = Screen.Height / Screen.TwipsPerPixelY / 2 - (rectMsg.Bottom - rectMsg.top) / 2
SetWindowPos wParam, 0, x, y, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE
'Release the CBT hook
UnhookWindowsHookEx hHook
End If
WinProcCenterScreen = False
End Function

Private Function WinProcCenterForm(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim rectForm As RECT, rectMsg As RECT
Dim x As Long, y As Long
'On HCBT_ACTIVATE, show the MsgBox centered over Form1
If lMsg = HCBT_ACTIVATE Then
'Get the coordinates of the form and the message box so that
'you can determine where the center of the form is located
GetWindowRect parenthWnd, rectForm
GetWindowRect wParam, rectMsg
x = (rectForm.left + (rectForm.Right - rectForm.left) / 2) - ((rectMsg.Right - rectMsg.left) / 2)
y = (rectForm.top + (rectForm.Bottom - rectForm.top) / 2) - ((rectMsg.Bottom - rectMsg.top) / 2)
'Position the msgbox
SetWindowPos wParam, 0, x, y, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE
'Release the CBT hook
UnhookWindowsHookEx hHook
End If
WinProcCenterForm = False
End Function

用API调出保存文件对话框时，若用户选了一个已存在的文件，如何弹出"文件已存在，要覆盖吗"的消息框?

相关推荐