"Seth1982" <***@gmail.com> ha scritto nel messaggio news:***@i40g2000cwc.googlegroups.com...
[cut]
<Quindi, niente minimizzazione!
<Ciao,
<Seth1982
Eppure questa Form permette anche la minimizzazione:
FORM:
'***************************************************************************
'*
'* MODULE NAME: SIZEABLE USERFORM
'* AUTHOR: STEPHEN BULLEN, Business Modelling Solutions Ltd.
'* TIM CLEM
'*
'* CONTACT: ***@BMSLtd.co.uk
'* WEB SITE: http://www.BMSLtd.co.uk
'*
'* DESCRIPTION: Makes a userform resizeable and reacts to the form being
resized
'*
'* THIS MODULE: Handles the userform's resizing
'*
'* PROCEDURES:
'* UserForm_Activate Instantiates a class module to make the form
sizeable
'* UserForm_Resize Sizes and positions the controls on the form when
resized
'* btnOK_Click Closes the form when the OK button is clicked
'*
'* Adapted to ArcMap from Excel by Kirk Kuykendall ***@ambergis.com
'* http://www.ambergis.com
'***************************************************************************
Option Explicit
Option Compare Text
'Declare a new instance of our form changer
Dim oFormChanger As New CFormChanger
Private Sub btnChangeIcon_Click()
Dim vFile As Variant
Dim pGetStringDialog As IGetStringDialog
Set pGetStringDialog = New GetStringDialog
If Not pGetStringDialog.DoModal("Enter a file that has icons
(.ico,.exe,.dll)", "File:", "", 0) Then
Debug.Print "canceled"
Exit Sub
Else
vFile = pGetStringDialog.Value
End If
If Dir(vFile) = "" Then
MsgBox "file not found: " & vFile
Exit Sub
End If
'vFile = Application.GetOpenFilename("Icon files
(*.ico;*.exe;*.dll),*.ico;*.exe;*.dll", 0, "Open Icon File", "Open", False)
'Showing dialog sets the form modeless, so check it
oFormChanger.Modal = cbModal
If vFile = False Then Exit Sub
oFormChanger.IconPath = vFile
End Sub
Private Sub UserForm_Activate()
'Initialise everything to show
cbModal.Value = True
cbCaption.Value = True
cbCloseBtn.Value = True
cbIcon.Value = True
cbMaximize.Value = True
cbMinimize.Value = True
cbSizeable.Value = True
cbSysmenu.Value = True
cbTaskBar.Value = False
cbSmallCaption.Value = False
'Set the form changer to change this userform
Set oFormChanger.Form = Me
'Make sure everything is in the right place to start with
UserForm_Resize
End Sub
Private Sub UserForm_Resize()
Dim dFrameCols As Double, dFrameRows As Double, dFrameHeight As Double
Dim i As Integer, j As Integer
'Standard control gap of 6pts
Const dGAP As Integer = 6
'Exit the sub if we've been minimized
If Me.InsideWidth = 0 Then Exit Sub
'Set controls that don't move/size
With lblMessage 'The position of the "Message" label
.Top = dGAP
.Left = dGAP
End With
With tbMessage 'The position of the message box (the size changes,
not the position)
.Top = dGAP + lblMessage.Height + dGAP
.Left = dGAP
End With
fraStyle.Left = dGAP
'Don't let the form get less than a certain height - must have at least
the message and button
If Me.InsideHeight < lblMessage.Height + btnOK.Height + fraStyle.Height
+ dGAP * 5 Then
'Reset the height, allowing for the form's border (Height -
InsideHeight)
Me.Height = lblMessage.Height + btnOK.Height + fraStyle.Height +
dGAP * 5 + Me.Height - Me.InsideHeight
End If
'Don't let the form get less than a certain width - must be as wide as
the biggest check box, plus the standard gap
If Me.InsideWidth < cbMaximize.Width + fraStyle.Width -
fraStyle.InsideWidth + dGAP * 4 Then
'Reset the width, allowing for the form's border (Width -
InsideWidth)
Me.Width = cbMaximize.Width + fraStyle.Width - fraStyle.InsideWidth
+ dGAP * 4
End If
'Work out the new dimensions of the frame (as the check boxes move
within the frame)
With fraStyle
If (Me.InsideWidth - dGAP * 3 - (.Width - .InsideWidth)) \
(cbMaximize.Width + dGAP) > 1 Then
dFrameCols = (Me.InsideWidth - dGAP * 3 - (.Width -
.InsideWidth)) \ (cbMaximize.Width + dGAP)
Else
dFrameCols = 1
End If
dFrameRows = .Controls.Count / dFrameCols
If dFrameRows <> Int(dFrameRows) Then dFrameRows = Int(dFrameRows) +
1
dFrameHeight = dFrameRows * cbMaximize.Height + dGAP + .Height -
.InsideHeight
End With
'Don't allow the form width to decrease so that there's no room for the
checkboxes
'i.e. decreasing the width causes the check boxes to require an extra
row, which doesn't fit.
If Me.InsideHeight <= btnOK.Height + lblMessage.Height + dFrameHeight +
dGAP * 5 Then
'Reset the width, allowing for the form's border (Width -
InsideWidth)
Me.Width = fraStyle.Width + dGAP * 2 + Me.Width - Me.InsideWidth
'Recalculate the frame's dimensions with the changed form's width
With fraStyle
If (Me.InsideWidth - dGAP * 3 - (.Width - .InsideWidth)) \
(cbMaximize.Width + dGAP) > 1 Then
dFrameCols = (Me.InsideWidth - dGAP * 3 - (.Width -
.InsideWidth)) \ (cbMaximize.Width + dGAP)
Else
dFrameCols = 1
End If
dFrameRows = .Controls.Count / dFrameCols
If dFrameRows <> Int(dFrameRows) Then dFrameRows =
Int(dFrameRows) + 1
dFrameHeight = dFrameRows * cbMaximize.Height + dGAP + .Height -
.InsideHeight
End With
End If
'Set the OK button to be in the middle at the bottom
With btnOK
.Left = (Me.InsideWidth - btnOK.Width) / 2
.Top = Me.InsideHeight - btnOK.Height - dGAP
End With
'Set the frame to be as wide as the box and move the check boxes in it
to fit
With fraStyle
.Width = Me.InsideWidth - dGAP * 2
.Height = dFrameHeight
'Reposition the controls in the frame, according to their tab order
For i = 0 To .Controls.Count - 1
For j = 0 To .Controls.Count - 1
With .Controls(j)
If .TabIndex = i Then
.Left = (i Mod dFrameCols) * (cbMaximize.Width +
dGAP) + dGAP
.Top = Int(i / dFrameCols) * cbMaximize.Height +
dGAP
End If
End With
Next
Next
.Top = btnOK.Top - dGAP - .Height
End With
'Userform is big enough, so set the message box's height and width to
fill it
With tbMessage
.Width = Me.InsideWidth - dGAP * 2
'Don't allow the height to go negative
If (fraStyle.Top - .Top - dGAP) > 0 Then
.Height = fraStyle.Top - .Top - dGAP
Else
.Height = 0
End If
End With
End Sub
Private Sub cbModal_Change()
oFormChanger.Modal = cbModal.Value
CheckEnabled
End Sub
Private Sub cbSizeable_Change()
oFormChanger.Sizeable = cbSizeable.Value
CheckBorderStyle
End Sub
Private Sub cbCaption_Change()
oFormChanger.ShowCaption = cbCaption.Value
CheckBorderStyle
CheckEnabled
End Sub
Private Sub cbSysmenu_Change()
oFormChanger.ShowSysMenu = cbSysmenu.Value
CheckEnabled
End Sub
Private Sub cbTaskBar_Change()
oFormChanger.ShowTaskBarIcon = cbTaskBar.Value
CheckEnabled
End Sub
Private Sub cbSmallCaption_Change()
oFormChanger.SmallCaption = cbSmallCaption.Value
CheckEnabled
End Sub
Private Sub cbIcon_Change()
oFormChanger.ShowIcon = cbIcon.Value
CheckEnabled
End Sub
Private Sub cbCloseBtn_Change()
oFormChanger.ShowCloseBtn = cbCloseBtn.Value
CheckEnabled
End Sub
Private Sub cbMaximize_Change()
oFormChanger.ShowMaximizeBtn = cbMaximize.Value
CheckEnabled
End Sub
Private Sub cbMinimize_Change()
oFormChanger.ShowMinimizeBtn = cbMinimize.Value
CheckEnabled
End Sub
Private Sub btnOK_Click()
Unload Me
End Sub
Private Sub CheckBorderStyle()
'If the useform is not sizeable and doesn't have a caption,
'Windows draws it without a border, and we need to apply our
'own 3D effect.
If Not (cbSizeable Or cbCaption) Then
Me.SpecialEffect = fmSpecialEffectRaised
Else
Me.SpecialEffect = fmSpecialEffectFlat
End If
End Sub
Private Sub CheckEnabled()
'Without a system menu, we can't have the close, max or min buttons
cbSysmenu.Enabled = cbCaption
cbCloseBtn.Enabled = cbSysmenu And cbCaption
cbIcon.Enabled = cbSysmenu And cbCaption And Not cbSmallCaption
cbMaximize.Enabled = cbSysmenu And cbCaption
cbMinimize.Enabled = cbSysmenu And cbCaption
btnChangeIcon.Enabled = cbIcon
End Sub
MODULO CLASSE:
Option Explicit
'Windows API calls to do all the dirty work!
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal
lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA"
(ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA"
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long,
ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal
nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal
nCmdShow As Long) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hWnd As Long,
ByVal fEnable As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As
Long
Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA"
(ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As
Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA"
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal
lParam As Long) As Long
'Lots of window styles for us to play with!
Private Const GWL_STYLE As Long = (-16) 'The offset of a window's
style
Private Const GWL_EXSTYLE As Long = (-20) 'The offset of a window's
extended style
Private Const WS_CAPTION As Long = &HC00000 'Style to add a titlebar
Private Const WS_SYSMENU As Long = &H80000 'Style to add a system
menu
Private Const WS_THICKFRAME As Long = &H40000 'Style to add a sizable
frame
Private Const WS_MINIMIZEBOX As Long = &H20000 'Style to add a Minimize
box on the title bar
Private Const WS_MAXIMIZEBOX As Long = &H10000 'Style to add a Maximize
box to the title bar
Private Const WS_POPUP As Long = &H80000000 'Standard option, cleared
when showing a task bar icon
Private Const WS_VISIBLE As Long = &H10000000 'Standard option, cleared
when showing a task bar icon
Private Const WS_EX_DLGMODALFRAME As Long = &H1 'Controls if the window
has an icon
Private Const WS_EX_APPWINDOW As Long = &H40000 'Application Window: shown
on taskbar
Private Const WS_EX_TOOLWINDOW As Long = &H80 'Tool Window: small
titlebar
'Constant to identify the Close menu item
Private Const SC_CLOSE As Long = &HF060
'Constants for hide or show a window
Private Const SW_HIDE As Long = 0
Private Const SW_SHOW As Long = 5
'Constants for Windows messages
Private Const WM_SETICON = &H80
'Variables to store the various selections/options
Dim hWndForm As Long, mbSizeable As Boolean, mbCaption As Boolean, mbIcon As
Boolean, miModal As Integer
Dim mbMaximize As Boolean, mbMinimize As Boolean, mbSysMenu As Boolean,
mbCloseBtn As Boolean
Dim mbAppWindow As Boolean, mbToolWindow As Boolean, msIconPath As String
Dim moForm As Object
Public Property Set Form(oForm As Object)
'Get the userform's window handle
' If Val(Application.Version) < 9 Then
' hWndForm = FindWindow("ThunderXFrame", oForm.Caption) 'XL97
' Else
hWndForm = FindWindow("ThunderDFrame", oForm.Caption) 'XL2000 (and
ArcMap too)
' End If
'Remember the form for later
Set moForm = oForm
'Set the form's style
SetFormStyle
'Update the form's icon
ChangeIcon
End Property
'Property procedure to get and set the form's window styles
Public Property Let Sizeable(bSizeable As Boolean)
mbSizeable = bSizeable
SetFormStyle
End Property
Public Property Get Sizeable() As Boolean
Sizeable = mbSizeable
End Property
Public Property Let ShowCaption(bCaption As Boolean)
mbCaption = bCaption
SetFormStyle
End Property
Public Property Get ShowCaption() As Boolean
ShowCaption = mbCaption
End Property
Public Property Let Modal(bModal As Boolean)
miModal = Abs(CInt(Not bModal))
'Make the form modal or modeless by enabling/disabling Excel itself
EnableWindow FindWindow("XLMAIN", Application.Caption), miModal
End Property
Public Property Get Modal() As Boolean
Modal = (miModal <> 1)
End Property
Public Property Let ShowIcon(bIcon As Boolean)
mbIcon = Not bIcon
ChangeIcon
SetFormStyle
End Property
Public Property Get ShowIcon() As Boolean
ShowIcon = (mbIcon <> 1)
End Property
Public Property Let IconPath(sNewPath As String)
msIconPath = sNewPath
ChangeIcon
End Property
Public Property Get IconPath() As String
IconPath = msIconPath
End Property
Public Property Let ShowMaximizeBtn(bMaximize As Boolean)
mbMaximize = bMaximize
SetFormStyle
End Property
Public Property Get ShowMaximizeBtn() As Boolean
ShowMaximizeBtn = mbMaximize
End Property
Public Property Let ShowMinimizeBtn(bMinimize As Boolean)
mbMinimize = bMinimize
SetFormStyle
End Property
Public Property Get ShowMinimizeBtn() As Boolean
ShowMinimizeBtn = mbMinimize
End Property
Public Property Let ShowSysMenu(bSysMenu As Boolean)
mbSysMenu = bSysMenu
SetFormStyle
End Property
Public Property Get ShowSysMenu() As Boolean
ShowSysMenu = mbSysMenu
End Property
Public Property Let ShowCloseBtn(bCloseBtn As Boolean)
mbCloseBtn = bCloseBtn
SetFormStyle
End Property
Public Property Get ShowCloseBtn() As Boolean
ShowCloseBtn = mbCloseBtn
End Property
Public Property Let ShowTaskBarIcon(bAppWindow As Boolean)
'If changing from showing an icon to not showing it, hide the window to
remove the icon
If hWndForm <> 0 And mbAppWindow And Not bAppWindow Then
'Enable the Excel window, so we don't lose focus
EnableWindow FindWindow("XLMAIN", Application.Caption), True
ShowWindow hWndForm, SW_HIDE
End If
mbAppWindow = bAppWindow
SetFormStyle
'Repaint the userform, to ensure everything is updated correctly
moForm.Repaint
'Set the Excel window's enablement to the correct choice
EnableWindow FindWindow("XLMAIN", Application.Caption), miModal
End Property
Public Property Get ShowTaskBarIcon() As Boolean
ShowTaskBarIcon = mbAppWindow
End Property
Public Property Let SmallCaption(bToolWindow As Boolean)
mbToolWindow = bToolWindow
SetFormStyle
End Property
Public Property Get SmallCaption() As Boolean
SmallCaption = mbToolWindow
End Property
'Routine to set the form's window style
Private Sub SetFormStyle()
Dim iStyle As Long, hMenu As Long, hID As Long, iItems As Integer
'Have we got a form to set?
If hWndForm = 0 Then Exit Sub
iStyle = GetWindowLong(hWndForm, GWL_STYLE)
'Build up the basic window style flags for the form
If mbCaption Then iStyle = iStyle Or WS_CAPTION Else iStyle = iStyle And
Not WS_CAPTION
If mbSysMenu Then iStyle = iStyle Or WS_SYSMENU Else iStyle = iStyle And
Not WS_SYSMENU
If mbSizeable Then iStyle = iStyle Or WS_THICKFRAME Else iStyle = iStyle
And Not WS_THICKFRAME
If mbMinimize Then iStyle = iStyle Or WS_MINIMIZEBOX Else iStyle =
iStyle And Not WS_MINIMIZEBOX
If mbMaximize Then iStyle = iStyle Or WS_MAXIMIZEBOX Else iStyle =
iStyle And Not WS_MAXIMIZEBOX
If mbAppWindow Then iStyle = iStyle And Not WS_VISIBLE And Not WS_POPUP
Else iStyle = iStyle Or WS_VISIBLE Or WS_POPUP
'Set the basic window styles
SetWindowLong hWndForm, GWL_STYLE, iStyle
iStyle = GetWindowLong(hWndForm, GWL_EXSTYLE)
'Build up and set the extended window style
If mbIcon Then iStyle = iStyle Or WS_EX_DLGMODALFRAME Else iStyle =
iStyle And Not WS_EX_DLGMODALFRAME
If mbAppWindow Then iStyle = iStyle Or WS_EX_APPWINDOW Else iStyle =
iStyle And Not WS_EX_APPWINDOW
If mbToolWindow Then iStyle = iStyle Or WS_EX_TOOLWINDOW Else iStyle =
iStyle And Not WS_EX_TOOLWINDOW
SetWindowLong hWndForm, GWL_EXSTYLE, iStyle
'Handle the close button differently
If mbCloseBtn Then
'We want it, so reset the control menu
hMenu = GetSystemMenu(hWndForm, 1)
Else
'We don't want it, so delete it from the control menu
hMenu = GetSystemMenu(hWndForm, 0)
DeleteMenu hMenu, SC_CLOSE, 0&
End If
'Show the window with the changes
ShowWindow hWndForm, SW_SHOW
DrawMenuBar hWndForm
SetFocus hWndForm
End Sub
Private Sub ChangeIcon()
Dim hIcon As Long
On Error Resume Next
If hWndForm <> 0 Then
Err.Clear
If msIconPath = "" Then
hIcon = 0
ElseIf Dir(msIconPath) = "" Then
hIcon = 0
ElseIf Err.Number <> 0 Then
hIcon = 0
ElseIf Not mbIcon Then
'Get the icon from the source
hIcon = ExtractIcon(0, msIconPath, 0)
Else
hIcon = 0
End If
'Set the big (32x32) and small (16x16) icons
SendMessage hWndForm, WM_SETICON, True, hIcon
SendMessage hWndForm, WM_SETICON, False, hIcon
End If
End Sub