Problem with recent Drop Down List Code

[krislyn]

I recently got this code from Bob and just today tested the check boxes
Problem is when I try to check any box beyond the first column, it wil
automatically check the box in the first column only.
Here is the code.

Sub SelectSheets()
Dim i As Long
Dim iRows As Long
Dim TopPos As Long
Dim LeftPos As Long
Dim SheetCount As Long
Dim cMaxLetters As Long
Dim cLeftWidth As Long
Dim PrintDlg As DialogSheet
Dim CurrentSheet
Dim cb As CheckBox
Dim fInclude As Boolean
Dim arySheets

Application.ScreenUpdating = False

ReDim arySheets(0)

' Check for protected workbook
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If

' Add a temporary dialog sheet
Set CurrentSheet = ActiveSheet
Set PrintDlg = ActiveWorkbook.DialogSheets.Add

SheetCount = 0

'first count the items that apply
For i = 1 To ActiveWorkbook.Sheets.Count
Set CurrentSheet = ActiveWorkbook.Sheets(i)
fInclude = True
If CurrentSheet.Name = PrintDlg.Name Then
fInclude = False
ElseIf CurrentSheet.Visible <> xlSheetVisible Then
fInclude = False
ElseIf TypeName(CurrentSheet) = "Worksheet" Then
If Application.CountA(CurrentSheet.Cells) = 0 Then
fInclude = False
End If
End If
If fInclude Then
SheetCount = SheetCount + 1
ReDim Preserve arySheets(SheetCount)
arySheets(SheetCount) = CurrentSheet.Name
End If
Next i

If SheetCount = 0 Then
MsgBox "All worksheets are empty."
PrintDlg.Delete
Exit Sub
End If

iRows = Int((SheetCount + 1) / 2)

' Add the checkboxes
TopPos = 40
LeftPos = 78
For i = 1 To UBound(arySheets, 1)
With Sheets(arySheets(i))
If Len(.Name) > cMaxLetters Then
cMaxLetters = Len(.Name)
End If
TopPos = TopPos + 13
PrintDlg.CheckBoxes.Add LeftPos, TopPos, 150, 16.5
PrintDlg.CheckBoxes(i).Text = .Name
End With
If i = iRows Then
TopPos = 40
cLeftWidth = 30 + (cMaxLetters * 4) + 10 + 24 + 8 - 10
LeftPos = cLeftWidth + 78
cMaxLetters = 0
End If
Next i

' Move the OK and Cancel buttons
With PrintDlg
.Buttons.Left = cLeftWidth + 108 + (cMaxLetters * 4) + 10 + 24 + 8


' Set dialog height, width, and caption
With .DialogFrame
.Height = Application.Max(68, (iRows * 13) + 40)
.Width = 108 + (cMaxLetters * 4) + 10 + 24 + 8 - 10 + cLeftWidth
.Caption = "Select sheets to print"
End With

' Change tab order of OK and Cancel buttons
' so the 1st option button will have the focus
.Buttons("Button 2").BringToFront
.Buttons("Button 3").BringToFront

' Display the dialog box
CurrentSheet.Activate
Application.ScreenUpdating = True
If .Show Then
For Each cb In PrintDlg.CheckBoxes
If cb.Value = xlOn Then
Worksheets(cb.Caption).Activate
ActiveSheet.PrintOut
' ActiveSheet.PrintPreview 'for debugging
End If
Next cb
End If

' Delete temporary dialog sheet (without a warning)
Application.DisplayAlerts = False
.Delete
End With

' Reactivate original sheet
CurrentSheet.Activate
End Sub



Thanks for any help!
krisly

 

[Dave Peterson]

What's happening is the checkbox box (the whole thing including the caption) is
extending into the second column.

In fact, if you try it again, you can click to the right of the second column of
names (near the ok and cancel buttons) and you'll get the second column.

There's a line in Bob's code that looks like this:

PrintDlg.CheckBoxes(i).Text = .Name

Try adding this line directly after it:

PrintDlg.CheckBoxes(i).Width = 30 + (cMaxLetters * 4) + 10 + 24 + 8 - 10

(It seemed to work in my tests.)

I don't know how Bob came up with that expression (it looks a lot like trial and
error <vbg>), but resizing the checkbox seemed to work wonders!