Attribute VB_Name = "basCommonDialog" Option ExplicitType RECT left As Long top As Long Right As Long Bottom As Long End TypeDeclare 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 LongConst GWL_HINSTANCE = (-6) Const SWP_NOSIZE = &H1 Const SWP_NOZORDER = &H4 Const SWP_NOACTIVATE = &H10 Const HCBT_ACTIVATE = 5 Const WH_CBT = 5Dim hHook As LongDeclare 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 LongDeclare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As LongPublic 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 = 256Public 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_HIDEREADONLYPublic 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 TypeType NMHDR hwndFrom As Long idfrom As Long code As Long End TypeType OFNOTIFY hdr As NMHDR lpOFN As OPENFILENAME pszFile As String ' May be NULL End TypeType 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 TypeType 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 TypePublic 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 TypePublic 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 = &H100Public Const COLOR_FLAGS = CC_FULLOPEN Or CC_ANYCOLOR Or CC_RGBINITPublic 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 = &H1000000Public 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 = &H400Public 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 = 2Type 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 TypePublic 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 = &H200000Type DEVNAMES wDriverOffset As Integer wDeviceOffset As Integer wOutputOffset As Integer wDefault As Integer End TypePublic Const DN_DEFAULTPRN = &H1Public Type SelectedFile nFilesSelected As Integer sFiles() As String sLastDirectory As String bCanceled As Boolean End TypePublic Type SelectedColor oSelectedColor As OLE_COLOR bCanceled As Boolean End TypePublic 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 TypePublic FileDialog As OPENFILENAME Public ColorDialog As CHOOSECOLORS Public FontDialog As CHOOSEFONTS Public PrintDialog As PRINTDLGS Dim parenthWnd As LongPublic 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
'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 FunctionPublic 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 FunctionPublic 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
'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 FunctionPublic 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
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
'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 FunctionPrivate 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 FunctionPublic 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 LongConst GWL_HINSTANCE = (-6) Const SWP_NOSIZE = &H1 Const SWP_NOZORDER = &H4 Const SWP_NOACTIVATE = &H10 Const HCBT_ACTIVATE = 5 Const WH_CBT = 5Type RECT left As Long top As Long Right As Long Bottom As Long End TypeDim hHook As Long Dim parenthWnd As LongPublic 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 FunctionPrivate 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 FunctionPrivate 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
to Bardo(巴顿)，你要干什么
这个问题我也碰到过,不过我是用弹出窗口来实现的,也不是很繁,还可以通过弹出对话框来实现. 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'覆盖,不覆盖就继续
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
CommonDialog1.Flags = &H2&
用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
Option ExplicitType RECT
left As Long
top As Long
Right As Long
Bottom As Long
End TypeDeclare 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 LongConst GWL_HINSTANCE = (-6)
Const SWP_NOSIZE = &H1
Const SWP_NOZORDER = &H4
Const SWP_NOACTIVATE = &H10
Const HCBT_ACTIVATE = 5
Const WH_CBT = 5Dim hHook As LongDeclare 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 LongDeclare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As LongPublic 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 = 256Public 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_HIDEREADONLYPublic 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 TypeType NMHDR
hwndFrom As Long
idfrom As Long
code As Long
End TypeType OFNOTIFY
hdr As NMHDR
lpOFN As OPENFILENAME
pszFile As String ' May be NULL
End TypeType 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 TypeType 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 TypePublic 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 TypePublic 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 = &H100Public Const COLOR_FLAGS = CC_FULLOPEN Or CC_ANYCOLOR Or CC_RGBINITPublic 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 = &H1000000Public 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 = &H400Public 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 = 2Type 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 TypePublic 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 = &H200000Type DEVNAMES
wDriverOffset As Integer
wDeviceOffset As Integer
wOutputOffset As Integer
wDefault As Integer
End TypePublic Const DN_DEFAULTPRN = &H1Public Type SelectedFile
nFilesSelected As Integer
sFiles() As String
sLastDirectory As String
bCanceled As Boolean
End TypePublic Type SelectedColor
oSelectedColor As OLE_COLOR
bCanceled As Boolean
End TypePublic 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 TypePublic FileDialog As OPENFILENAME
Public ColorDialog As CHOOSECOLORS
Public FontDialog As CHOOSEFONTS
Public PrintDialog As PRINTDLGS
Dim parenthWnd As LongPublic 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 FunctionPublic 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 FunctionPublic 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 FunctionPublic 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 FunctionPrivate 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 FunctionPublic 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 LongConst GWL_HINSTANCE = (-6)
Const SWP_NOSIZE = &H1
Const SWP_NOZORDER = &H4
Const SWP_NOACTIVATE = &H10
Const HCBT_ACTIVATE = 5
Const WH_CBT = 5Type RECT
left As Long
top As Long
Right As Long
Bottom As Long
End TypeDim hHook As Long
Dim parenthWnd As LongPublic 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 FunctionPrivate 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 FunctionPrivate 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
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'覆盖,不覆盖就继续
'-------------------------------------------------------------
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
Dim f As FileSystemObject
Dim S As TextStream
Set f = CreateObject("Scripting.FileSystemObject")
If f.FileExists(me.commondlog1.filename) = True Then
msgbox "该文件已经存在"
end if