Common Dialog Cancel button

[Vasia]

How do we detect if Cancel button was pressed. If you're thinking of a CancelError
property - don't respond. It's not what I'm looking for.

Thank you all in advance.
No e-mail please.

[Eduardo A. Morcillo]

> How do we detect if Cancel button was pressed. If you're thinking of a
CancelError
> property - don't respond. It's not what I'm looking for.

With the Common Dialog control, the CancelError property and an On Error in
the code is the only way.

--
Eduardo A. Morcillo (MS-MVP)
http://www.domaindlx.com/e_morcillo

[Michael Culley]

Its not ideal but it actually works quite well, if you cancel then execution
jumps to the end of the function, which is what you want.

Alternatively, you could use the code below (paste it into a class and call
it CommonDialog or something like it). You will need to strip out the error
handling and line numbering.

--
Michael Culley
www.vbdotcom.com

Option Explicit

Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA"
(pChoosecolor As CHOOSECOLOR) As Long
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA"
(pChoosefont As CHOOSEFONT) As Long
Private Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hwnd
As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As
Long) 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 PRINTDLG Lib "comdlg32.dll" Alias "PrintDlgA"
(pPrintdlg As PRINTDLG) As Long
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () 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
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 GlobalSize Lib "kernel32" (ByVal hMem As Long) As
Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory"
(Destination As Any, Source As Any, ByVal Length As Long)
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64
Private Const FW_BOLD = 700

Private Const CDERR_DIALOGFAILURE = &HFFFF
Private Const CDERR_FINDRESFAILURE = &H6
Private Const CDERR_GENERALCODES = &H0
Private Const CDERR_INITIALIZATION = &H2
Private Const CDERR_LOADRESFAILURE = &H7
Private Const CDERR_LOADSTRFAILURE = &H5
Private Const CDERR_LOCKRESFAILURE = &H8
Private Const CDERR_MEMALLOCFAILURE = &H9
Private Const CDERR_MEMLOCKFAILURE = &HA
Private Const CDERR_NOHINSTANCE = &H4
Private Const CDERR_NOHOOK = &HB
Private Const CDERR_NOTEMPLATE = &H3
Private Const CDERR_REGISTERMSGFAIL = &HC
Private Const CDERR_STRUCTSIZE = &H1

Private Const FNERR_BUFFERTOOSMALL = &H3003
Private Const FNERR_FILENAMECODES = &H3000
Private Const FNERR_INVALIDFILENAME = &H3002
Private Const FNERR_SUBCLASSFAILURE = &H3001

Private Const DN_DEFAULTPRN = &H1

Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As Long
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(1 To LF_FACESIZE) As Byte
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
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 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 PRINTDLG
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
wDriverOffset As Integer
wDeviceOffset As Integer
wOutputOffset As Integer
wDefault As Integer
End Type

Public Enum HelpCmdEnum
HELP_COMMAND = &H102&
HELP_CONTENTS = &H3&
HELP_CONTEXT = &H1
HELP_CONTEXTPOPUP = &H8&
HELP_FORCEFILE = &H9&
HELP_HELPONHELP = &H4
HELP_INDEX = &H3
HELP_KEY = &H101
HELP_MULTIKEY = &H201&
HELP_PARTIALKEY = &H105&
HELP_QUIT = &H2
HELP_SETCONTENTS = &H5&
HELP_SETINDEX = &H5
HELP_SETWINPOS = &H203&
HELP_FINDER = &HB&
End Enum

Public Enum FontFlagsEnum
CF_ANSIONLY = &H400&
CF_APPLY = &H200&
CF_BOTH = &H3
CF_EFFECTS = &H100&
CF_TTONLY = &H40000
CF_FIXEDPITCHONLY = &H4000&
CF_FORCEFONTEXIST = &H10000
CF_INITTOLOGFONTSTRUCT = &H40&
CF_LIMITSIZE = &H2000&
CF_WYSIWYG = &H8000
CF_NOFACESEL = &H80000
CF_NOOEMFONTS = &H800&
CF_NOSCRIPTSEL = &H800000
CF_NOSIMULATIONS = &H1000&
CF_NOSIZESEL = &H200000
CF_NOSTYLESEL = &H100000
CF_NOVECTORFONTS = &H800&
CF_NOVERTFONTS = &H1000000
CF_SCREENFONTS = &H1
CF_PRINTERFONTS = &H2
CF_SCRIPTSONLY = &H400&
CF_SCALABLEONLY = &H20000
CF_SELECTSCRIPT = &H400000
CF_SHOWHELP = &H4&
CF_USESTYLE = &H80&
End Enum

'internal property buffers

Private iAction As Integer 'internal buffer for Action property
Private bCancelError As Boolean 'internal buffer for CancelError property
Private lColor As Long 'internal buffer for Color property
Private lCopies As Long 'internal buffer for lCopies property
Private sDefaultExt As String 'internal buffer for sDefaultExt property
Private sDialogTitle As String 'internal buffer for DialogTitle property
Private sFileName As String 'internal buffer for FileName property
Private sFileTitle As String 'internal buffer for FileTitle property
Private sFilter As String 'internal buffer for Filter property
Private iFilterIndex As Integer 'internal buffer for FilterIndex property
Private lFlags As Long 'internal buffer for Flags property
Private bFontBold As Boolean 'internal buffer for FontBold property
Private bFontItalic As Boolean 'internal buffer for FontItalic property
Private sFontName As String 'internal buffer for FontName property
Private lFontSize As Long 'internal buffer for FontSize property
Private bFontStrikethru As Boolean 'internal buffer for FontStrikethru
property
Private bFontUnderline As Boolean 'internal buffer for FontUnderline
property
Private lFromPage As Long 'internal buffer for FromPage property
Private lhwnd As Long 'internal buffer for hdc property
Private lhdc As Long 'internal buffer for hdc property
Private lHelpCommand As Long 'internal buffer for HelpCommand property
Private sHelpData As String 'internal buffer for HelpContext property
Private sHelpFile As String 'internal buffer for HelpFile property
Private sHelpKey As String 'internal buffer for HelpKey property
Private sInitDir As String 'internal buffer for InitDir property
Private lMax As Long 'internal buffer for Max property
Private lMaxFileSize As Long 'internal buffer for MaxFileSize property
Private lMin As Long 'internal buffer for Min property
Private objObject As Object 'internal buffer for Object property
Private iPrinterDefault As Integer 'internal buffer for PrinterDefault
property
Private lToPage As Long 'internal buffer for ToPage property
Private lDeviceName As String 'internal buffer for DeviceName property
Private lDriverName As String 'internal buffer for DriverName property
Private lPort As String 'internal buffer for Port property

Private lApiReturn As Long 'internal buffer for APIReturn property
Private lExtendedError As Long 'internal buffer for ExtendedError
property
Private lCancelled As Boolean 'internal buffer for Cancelled property

Public Property Get Filter() As String
On Error GoTo Fail

'return object's Filter property
1 Filter = sFilter

Exit Property
Fail:
ErrReport.AddToStackRaiseError TypeName(Me), "Filter[GET]"
End Property

Public Sub ShowColor()
On Error GoTo Fail

'display the color dialog box

Dim tChooseColor As CHOOSECOLOR
Dim alCustomColors(15) As Long
Dim lCustomColorSize As Long
Dim lCustomColorAddress As Long
Dim lMemHandle As Long

Dim n As Integer

On Error GoTo ShowColorError


'*** init property buffers

1 iAction = 3 'Action property - ShowColor
2 lApiReturn = 0 'APIReturn property
3 lExtendedError = 0 'ExtendedError property


'*** prepare tChooseColor data

'lStructSize As Long
4 tChooseColor.lStructSize = Len(tChooseColor)

'hwndOwner As Long
5 tChooseColor.hwndOwner = lhwnd

'hInstance As Long

'rgbResult As Long
6 tChooseColor.rgbResult = lColor

'lpCustColors As Long
' Fill custom colors array with all white
7 For n = 0 To UBound(alCustomColors)
8 alCustomColors(n) = &HFFFFFF
9 Next
' Get size of memory needed for custom colors
10 lCustomColorSize = Len(alCustomColors(0)) * 16
' Get a global memory block to hold a copy of the custom colors
11 lMemHandle = GlobalAlloc(GHND, lCustomColorSize)

12 If lMemHandle = 0 Then
Exit Sub
End If
' Lock the custom color's global memory block
13 lCustomColorAddress = GlobalLock(lMemHandle)
14 If lCustomColorAddress = 0 Then
Exit Sub
End If
' Copy custom colors to the global memory block
15 Call CopyMemory(ByVal lCustomColorAddress, alCustomColors(0),
lCustomColorSize)

16 tChooseColor.lpCustColors = lCustomColorAddress

'flags As Long
17 tChooseColor.flags = lFlags

'lCustData As Long
'lpfnHook As Long
'lpTemplateName As String


'*** call the ChooseColor API function
18 lApiReturn = CHOOSECOLOR(tChooseColor)


'*** handle return from ChooseColor API function
19 Select Case lApiReturn
Case 0 'user canceled
20 If bCancelError = True Then
'generate an error
On Error GoTo 0
21 Err.Raise Number:=vbObjectError + 894, _
Description:="Cancel Pressed"
Exit Sub
End If

22 Case 1 'user selected a color
'update property buffer
23 lColor = tChooseColor.rgbResult

24 Case Else 'an error occured
'call CommDlgExtendedError
25 lExtendedError = CommDlgExtendedError

End Select

Exit Sub

ShowColorError:
Exit Sub

Exit Sub
Fail:
ErrReport.AddToStackRaiseError TypeName(Me), "ShowColor"
End Sub

Public Sub ShowFont()
On Error GoTo Fail

'display the font dialog box

Dim tLogFont As LOGFONT
Dim tChooseFont As CHOOSEFONT

Dim lLogFontSize As Long
Dim lLogFontAddress As Long
Dim lMemHandle As Long

On Error GoTo ShowFontError

'*** init property buffers

1 iAction = 4 'Action property - ShowFont
2 lApiReturn = 0 'APIReturn property
3 lExtendedError = 0 'ExtendedError property


'*** prepare tChooseFont data

'tLogFont.lfHeight As Long
'tLogFont.lfWidth As Long
'tLogFont.lfEscapement As Long
'tLogFont.lfOrientation As Long

'tLogFont.lfWeight As Long - init from FontBold property
4 If bFontBold = True Then
5 tLogFont.lfWeight = FW_BOLD
End If

'tLogFont.lfItalic As Byte - init from FontItalic property
6 If bFontItalic = True Then
7 tLogFont.lfItalic = 1
End If

'tLogFont.lfUnderline As Byte - init from FontUnderline property
8 If bFontUnderline = True Then
9 tLogFont.lfUnderline = 1
End If

'tLogFont.lfStrikeOut As Byte - init from FontStrikethru property
10 If bFontStrikethru = True Then
11 tLogFont.lfStrikeOut = 1
End If

'tLogFont.lfCharSet As Byte
'tLogFont.lfOutPrecision As Byte
'tLogFont.lfClipPrecision As Byte
'tLogFont.lfQuality As Byte
'tLogFont.lfPitchAndFamily As Byte
'tLogFont.lfFaceName(LF_FACESIZE) As Byte

'tChooseFont.lStructSize As Long
12 tChooseFont.lStructSize = Len(tChooseFont)

'tChooseFont.hwndOwner As Long
'tChooseFont.hdc As Long

'tChooseFont.lpLogFont As Long
13 lLogFontSize = Len(tLogFont)

' Get a global memory block to hold a copy of tLogFont - exit on failure
14 lMemHandle = GlobalAlloc(GHND, lLogFontSize)
15 If lMemHandle = 0 Then
Exit Sub
End If

' Lock tLogFont's global memory block - exit on failure
16 lLogFontAddress = GlobalLock(lMemHandle)
17 If lLogFontAddress = 0 Then
Exit Sub
End If

' Copy tLogFont to the global memory block
18 Call CopyMemory(ByVal lLogFontAddress, tLogFont, lLogFontSize)

19 tChooseFont.lpLogFont = lLogFontAddress

'tChooseFont.iPointSize As Long - init from FontSize property
20 tChooseFont.iPointSize = lFontSize * 10

'tChooseFont.flags As Long - init from Flags property
21 tChooseFont.flags = lFlags

'tChooseFont.rgbColors As Long
'tChooseFont.lCustData As Long
'tChooseFont.lpfnHook As Long
'tChooseFont.lpTemplateName As String
'tChooseFont.hInstance As Long

'tChooseFont.lpszStyle As String
'sFont = Chr$(0) & Space$(20) & Chr$(0)
'tChooseFont.lpszStyle = sFont

'tChooseFont.nFontType As Integer
'tChooseFont.MISSING_ALIGNMENT As Integer
'tChooseFont.nSizeMin As Long
'tChooseFont.nSizeMax As Long


'*** call the CHOOSEFONT API function
22 lApiReturn = CHOOSEFONT(tChooseFont) 'store to APIReturn property


'*** handle return from CHOOSEFONT API function
23 Select Case lApiReturn
Case 0 'user canceled
24 If bCancelError = True Then
'generate an error
25 Err.Raise (2001)
Exit Sub
End If

26 Case 1 'user selected a font
' Copy global memory block to tLogFont
27 Call CopyMemory(tLogFont, ByVal lLogFontAddress,
lLogFontSize)

'tLogFont.lfWeight As Long - store to FontBold property
28 If tLogFont.lfWeight >= FW_BOLD Then
29 bFontBold = True
30 Else
31 bFontBold = False
End If

'tLogFont.lfItalic As Byte - store to FontItalic property
32 If tLogFont.lfItalic = 1 Then
33 bFontItalic = True
34 Else
35 bFontItalic = False
End If

'tLogFont.lfUnderline As Byte - store to FontUnderline property
36 If tLogFont.lfUnderline = 1 Then
37 bFontUnderline = True
38 Else
39 bFontUnderline = False
End If

'tLogFont.lfStrikeOut As Byte - store to FontStrikethru property
40 If tLogFont.lfStrikeOut = 1 Then
41 bFontStrikethru = True
42 Else
43 bFontStrikethru = False
End If

'tLogFont.lfFaceName(LF_FACESIZE) As Byte - store to FontName
property
44 FontName = sByteArrayToString(tLogFont.lfFaceName())

'tChooseFont.iPointSize As Long - store to FontSize property
45 lFontSize = CLng(tChooseFont.iPointSize / 10)

46 Case Else 'an error occured
'call CommDlgExtendedError
47 lExtendedError = CommDlgExtendedError 'store to
ExtendedError property

End Select
Exit Sub

ShowFontError:
Exit Sub

Exit Sub
Fail:
ErrReport.AddToStackRaiseError TypeName(Me), "ShowFont"
End Sub

Public Sub ShowHelp()
On Error GoTo Fail

'run winhelp.exe with the specified help file
Dim sHelpFileBuff As String
Dim lData As Long

On Error GoTo ShowHelpError

'*** init Private properties
1 iAction = 6 'Action property - ShowHelp
2 lApiReturn = 0 'APIReturn property
3 lExtendedError = 0 'ExtendedError property

'*** prepare the buffers and parameters for the API function
'sHelpFile is a null terminated string
4 sHelpFileBuff = sHelpFile & Chr$(0)

'sData is dependent on lHelpCommand
5 Select Case lHelpCommand
Case 0
6 lData = 0
7 Case Else
8 lData = sHelpData
End Select

'*** call the API function
9 lApiReturn = WinHelp(lhwnd, sHelpFile, lHelpCommand, lData) ' -
Store to APIReturn property

10 Select Case lApiReturn
Case 0 '
'call CommDlgExtendedError
11 lExtendedError = CommDlgExtendedError ' - store to
ExtendedErro220 64914 <3c673ec0$1@10.1.10.29> article retrieved - head and body follows
From: "Senthil Kumar" <jsenthil_kumar@hotmail.com>
Sender: "Senthil Kumar" <jsenthil_kumar@hotmail.com>
Reply-To: "Senthil Kumar" <jsenthil_kumar@hotmail.com>
Subject: Multiple MDI Child Forms
Newsgroups: vb.general
X-User-Info: 139.130.22.26 139.130.22.26
NNTP-Posting-Host: 10.1.10.29
Message-ID: <3c673ec0$1@10.1.10.29>
Date: 10 Feb 2002 19:47:12 -0800
X-Trace: 10 Feb 2002 19:47:12 -0800, 10.1.10.29
Lines: 11
Path: 10.1.10.29
Xref: 10.1.10.29 vb.general:64914


First my sincere Thanks for reading this. I have to create multiple
MDI Child Forms(say 30 nos.) inside an MDI Form. Each child form will
have the same number of controls(1 Text, 1 Label and 1 CheckBox).
I can create this very easily. The problem is, after creating all the
MDI Child Forms I can't manipulate any of the controls except for the
controls in the last MDI Child Form. The reason for this is, whenever I issue
'Set NewForm = New Form2', the previously created controls are lost.
How can I overcome this problem? The problem is very urgent.