P
PeteCresswell
In creating an Excel spreadsheet via MS Access VBA, I'm adding a
"sort" button to the top of each column.
Works fine locally or deployed over the LAN, but somebody's tripping
over it when run on a Citrix server.
Error# 1004: Programmatic access to Visual Basic Project is not
trusted
The lline of code in question:
--------------------------------------------------------
Dim myParentModule As VBComponent
13041 Set myParentModule =
myWB.VBProject.VBComponents.Add(vbext_ct_StdModule)
-------------------------------------------------------
VBComponent seems tb part of ...Program Files\Common Files\Microsoft
Shared\VBA\VBA6\VBE6EXT.OLB
"Seems" bc the path is too long to fit in the References dialog and
I'm winging it on the VBA6 part on.
Assuming I've got the .OLB right, does anybody know what's to be done
to make the problem go away? Something w/Citirx? Something w/
Windows Server?
For the masochistically-inclined, here's the whole schmeer:
==============================================
Public Sub SortButtons_Create(ByVal theRowNum_Buttons As Long, ByVal
theRowNum_DataFirst As Long, ByVal theRowNum_DataLast As Long, ByVal
theColNum_ButtonFirst As Long, ByVal theColNum_ButtonLast As Long,
ByVal theColNum_DataFirst As Long, ByVal theColNum_DataLast As Long,
ByVal theArrowColor As Long, ByRef theWS As Excel.Worksheet, Optional
theMacroName As String, Optional theColNum_SubTotals As Long, Optional
theSubTotals_Label As String)
13000 DebugStackPush mModuleName & ": SortButtons_Create"
13001 On Error GoTo SortButtons_Create_err
' PURPOSE: - To put a series of invisible rectangles on a
worksheet which, when clicked,
' call a routine that sorts the entire sheet's data on
that column's values.
' - To create up/down arrows to supplement the rectangles
by servint as visual indicator
' of what is sorted on and how
' - To create/install a macro named "SortSheet" that will
serve as the routine that sorts the sheet
' ACCEPTS: - Row number of the row to have the invisible
rectangles installed on it
' - Row number of the first row tb sorted
' - Row number of the last row tb sorted
' - Col number of first column that gets a button
' - Col number of last column that gets a button
' - Col number of first column tb sorted (generally
same as first col to get a button)
' - Col number of last column tb sorted (generally same
as last col to get a button)
' - Color tb used when drawing the Up/Down arrows. Must
be valid in Excel's scheme of things.
' e.g. 10 = Red
' - Pointer to the Excel.Worksheet where the buttons go
' - OPTIONAL name of sort macro name. TB used if/when
we need to install multiple
' macros in a single sheet - as with Market Value
Changes report, which has a
' separate macro for each report grouping.
' - OPTIONAL column number of label that identifies
subtotal lines (so they can be removed and
' not confuse the sort result)
' - OPTIONAL literal value of subtotal lines' label
'
' NOTES: 1) BEWARE OF Null CELLS. If a column on the sheet tb
sorted contains Null values,
' the Sort command will break down and the user will
not be able to flip-flop
' the direction. SO: For strings and dates, if the
cell were tb Null, you
' need to populate it with a space. For numerics, it
must be populated with
' zero. Let the formatting hide the zeros if the user
doesn't want to see them.
13002 Dim myWB As Excel.Workbook
Dim myRange As Excel.Range
Dim curCell As Excel.Range
Dim curButton As Shape
Dim curUpArrow As Shape
Dim curDownArrow As Shape
Dim myParentModule As VBComponent
Dim myCodeModule As CodeModule
Dim curRI As RangeInfo
Dim curCellAddress As String
Dim curColNumString As String
Dim myCode As String
Dim myMacroName As String
Dim okToSort As Boolean
Const myArrowHeight As Long = 5
Const myArrowWidth As Long = 5
Const myDefaultMacroName As String = "SortSheet" 'This value
is implicit in myCode1
' -----------------------------------------------------------
' We use these constants to assemble the macro tb added to the
SS
' which does the actual sorting
Const myCode01 As String = "Sub "
' concat myMacroName
Const myCode02 As String = _
"() " & vbCrLf & vbCrLf & _
"'PURPOSE: - To allow user to sort the entire sheet by
clicking on a column header" & vbCrLf & _
"' - To maintain visibility of up/down arrows
which indicate which cols are sorted and" & vbCrLf & _
"' the direction of the sort" & vbCrLf & _
"'" & vbCrLf & _
"' NOTES: 1) This routine's code was generated by the
same application" & vbCrLf & _
"' that created this spreadsheet. That is why
the data area's dimensions" & vbCrLf & _
"' are supplied via constants: the creating
app concatonated them into this code" & vbCrLf & _
"'
Pete Cresswell" & vbCrLf & _
"'
610-513-0066" & vbCrLf & _
" Dim myWS As Worksheet " &
vbCrLf & _
" Dim myRange As Range " &
vbCrLf & vbCrLf & _
" Dim i As Long " &
vbCrLf & _
" Dim R As Long " &
vbCrLf & _
" Dim topVal As String " &
vbCrLf & _
" Dim botVal As String " &
vbCrLf & _
" Dim okToSort As Boolean " &
vbCrLf & _
" Dim mySortCol As Long " &
vbCrLf & _
" Dim mySortOrder As Long " &
vbCrLf & _
" Dim myWeight As Long " &
vbCrLf & _
" Dim myLineStyle As Long " &
vbCrLf & _
" Dim myCallerName As String " &
vbCrLf & vbCrLf
Const myCode03 As String = _
" Static subTotals_Removed As Boolean " &
vbCrLf & _
" Static rowNum_LastData_Revised As Long " &
vbCrLf & vbCrLf & _
" Const rowNum_FirstData As Long = "
' concat theRowNum_DataFirst
Const myCode04 As String = " Const
rowNum_LastData As Long = "
Const myCode05 As String = " Const
colNum_FirstData As Long = "
Const myCode06 As String = " Const
colNum_LastData As Long = "
Const myCode07 As String = " Const
colNum_SubTotals As Long = "
Const myCode08 As String = " Const
subTotals_Label As String = """
Const myCode09 As String = _
" Set myWS = ActiveSheet " & vbCrLf & vbCrLf & _
"'
---------------------------------------------------------" & vbCrLf &
_
"' If creating routine has specified subtotals exist," &
vbCrLf & _
"' empty out entire line for each subtotal" & vbCrLf & _
"' " & vbCrLf & _
"' We *could* delete those lines, but that would
introduce" & vbCrLf & _
"' the complexities of adjusting boxes around data and
we" & vbCrLf & _
"' don't want to go there..." & vbCrLf & vbCrLf & _
" With myWS " & vbCrLf & _
" If subTotals_Removed = True Then
" & vbCrLf & _
" okToSort = True
" & vbLf & _
" Else
" & vbLf & _
" If MsgBox(""Sorting on this column will cause all
subtotals to be removed."" & vbLf & vbLf & ""Do you want to
continue?"", vbQuestion + vbYesNo) = vbYes Then" & vbCrLf & _
" rowNum_LastData_Revised = rowNum_LastData " &
vbCrLf & _
" If ((Len(subTotals_Label & """") > 0) And
(colNum_SubTotals > 0)) Then " & vbCrLf & _
"' First take care of last row if it is a
subtotal, preserving any bold bottom border" & vbCrLf & _
" R = rowNum_LastData_Revised " & vbCrLf & _
" If .Cells(R, colNum_SubTotals).Value =
subTotals_Label Then" & vbCrLf & _
" Set myRange = .Range(.Cells(R,
colNum_FirstData), .Cells(R, colNum_LastData))" & vbCrLf & _
" With myRange.Borders(xlEdgeBottom)" &
vbCrLf & _
" myWeight = .Weight" & vbCrLf & _
" myLineStyle = .LineStyle" & vbCrLf &
_
" End With"
Const myCode10 As String = _
" .Rows(rowNum_LastData_Revised).Delete" &
vbCrLf & _
" rowNum_LastData_Revised =
rowNum_LastData_Revised - 1" & vbCrLf & _
" R = rowNum_LastData_Revised" & vbCrLf & _
" Set myRange = .Range(.Cells(R,
colNum_FirstData), .Cells(R, colNum_LastData))" & vbCrLf & _
" With myRange.Borders(xlEdgeBottom)" &
vbCrLf & _
" .Weight = myWeight" & vbCrLf & _
" .LineStyle = myLineStyle" & vbCrLf &
_
" End With" & vbCrLf & _
" End If" & vbCrLf & vbCrLf & _
"' Now deal with all the other subtotals " &
vbCrLf & _
" For R = rowNum_FirstData To
rowNum_LastData" & vbCrLf & _
" If .Cells(R, colNum_SubTotals).Value =
subTotals_Label Then " & vbCrLf & _
" .Rows(R).Delete Shift:=xlDown " &
vbCrLf & _
" rowNum_LastData_Revised =
rowNum_LastData_Revised - 1 " & vbCrLf & _
" End If " & vbCrLf & _
" Next R " & vbCrLf & _
" subTotals_Removed = True " & vbCrLf & _
" Else " & vbCrLf & _
" subTotals_Removed = True " & vbCrLf & _
" End If" & vbCrLf & _
" okToSort = true" & vbCrLf & _
" End If" & vbCrLf & _
" End If" & vbCrLf & _
" End With " & vbCrLf & vbCrLf
Const myCode11 As String = _
"'
--------------------------------------------------------- " & vbCrLf &
_
"' Do the sorting thing..." & vbCrLf & vbCrLf & _
" if okToSort = true then " & vbCrLf & _
" With myWS " & vbCrLf & _
" myCallerName = .Shapes(Application.Caller).Name"
& vbCrLf & vbCrLf & _
" For i = colNum_FirstData To colNum_LastData" &
vbCrLf & _
" On Error Resume Next 'User may have
deleted 1 or more columns" & vbCrLf & _
" .Shapes("""
'Concat mymacroname
Const myCode12 As String = _
""" & Format$(i, ""000"") &
""Up"").Visible = False" & vbCrLf & _
" .Shapes("""
'Concat mymacroname
Const myCode13 As String = _
""" & Format$(i, ""000"") &
""Dn"").Visible = False" & vbCrLf
Const myCode14 As String = _
" On Error GoTo 0 " & vbCrLf & _
" Next i" & vbCrLf & vbCrLf & _
" mySortCol
= .Shapes(Application.Caller).TopLeftCell.Column " & vbCrLf & _
" Set myRange = .Range(.Cells(rowNum_FirstData,
colNum_FirstData), .Cells(rowNum_LastData_Revised, colNum_LastData)) "
& vbCrLf & vbCrLf
Const myCode15 As String = _
" topVal = uCase$(.Cells(rowNum_FirstData,
mySortCol).Value) " & vbCrLf & _
" botVal = uCase$(.Cells(rowNum_LastData_Revised,
mySortCol).Value) " & vbCrLf & _
"
" & vbCrLf & _
" If topVal < botVal
Then " & vbCrLf &
_
" mySortOrder =
xlDescending " & vbCrLf
& _
" On Error Resume Next 'User may have
deleted one or more arrows " & vbCrLf & _
" .Shapes(myCallerName & ""Dn"").Visible =
True " & vbCrLf & _
" On Error GoTo
0 " & vbCrLf
& _
"
Else
" & vbCrLf & _
" mySortOrder =
xlAscending " & vbCrLf
& _
" On Error Resume
Next " & vbCrLf &
_
" .Shapes(myCallerName & ""Up"").Visible =
True " & vbCrLf & _
" On Error GoTo
0 " & vbCrLf
& _
" End
If
" & vbCrLf & vbCrLf & _
" myRange.Sort key1:=.Cells(rowNum_FirstData,
mySortCol), order1:=mySortOrder " & vbCrLf & _
" End
With
" & vbCrLf & _
" End
If
" & vbCrLf & _
" End
Sub
"
'
------------------------------------------------------------------------
' If there are not multiple data rows specified or if there are no
data columns
' specified, call the whole thing off.
13010 If Abs((theRowNum_DataLast - theRowNum_DataFirst)) > 0 Then
13011 If Abs((theColNum_ButtonLast - theColNum_ButtonFirst)) > 0
Then
13012 okToSort = True
13013 End If
13019 End If
13020 If okToSort = True Then
'
------------------------------------------------------------------------
' Check to see if we have a special macro name
13030 If Len(theMacroName & "") = 0 Then
13031 myMacroName = myDefaultMacroName
13032 Else
13033 myMacroName = theMacroName
13039 End If
'
------------------------------------------------------------------------
' Create a code module in the target spreadsheet
' that will hold the code to handle our button click events
13040 Set myWB = theWS.Parent
13041 Set myParentModule =
myWB.VBProject.VBComponents.Add(vbext_ct_StdModule)
'13041 Set myParentModule =
myWB.VBProject.VBComponents("ThisWorkBook")
13049 Set myCodeModule = myParentModule.CodeModule
13050 myCode = myCode01 & myMacroName & _
myCode02 & vbCrLf & _
myCode03 & theRowNum_DataFirst & vbCrLf & _
myCode04 & theRowNum_DataLast & vbCrLf & _
myCode05 & theColNum_ButtonFirst & vbCrLf & _
myCode06 & theColNum_DataLast & vbCrLf & _
myCode07 & Val(theColNum_SubTotals & "") &
vbCrLf & _
myCode08 & theSubTotals_Label & Chr$(34) &
vbCrLf & _
myCode09 & vbCrLf & _
myCode10 & _
myCode11 & myMacroName & _
myCode12 & myMacroName & _
myCode13 & _
myCode14 & _
myCode15
13060 With myCodeModule
13061 .InsertLines .CountOfLines + 1, myCode
13069 End With
'
------------------------------------------------------------------------
' Now that we've got our macro code installed in the target Excel
workbook,
' we loop through the worksheet's columns, creating a rectangle/
button
' and a couple of directional indicator arrows in each column
header cell
' NB: If the text in a column header is right-justified, you'll
need to
' have done a .IndentLevel=1 to slide it over far enough so
the Up/Down
' arrows do not conflict with it
13070 With theWS
13071 Set myRange = .Range(.Cells(theRowNum_Buttons,
theColNum_ButtonFirst), .Cells(theRowNum_Buttons,
theColNum_ButtonLast))
13079 For Each curCell In myRange.Cells
13080 With curCell
13081 curCellAddress = .Address(ReferenceStyle:=xlR1C1)
13084 Set curButton
= .Parent.Shapes.AddShape(Type:=msoShapeRectangle, Top:=.Top,
Height:=.Height, Width:=.Width, Left:=.Left)
13085 Set curUpArrow
= .Parent.Shapes.AddShape(Type:=msoShapeIsoscelesTriangle, Top:=(.Top
+ .Height - myArrowHeight - 4), Height:=myArrowHeight,
Width:=myArrowWidth, Left:=(.Left + .Width - myArrowWidth - 2))
13086 Set curDownArrow
= .Parent.Shapes.AddShape(Type:=msoShapeIsoscelesTriangle, Top:=(.Top
+ .Height - myArrowHeight - 4), Height:=myArrowHeight,
Width:=myArrowWidth, Left:=(.Left + .Width - myArrowWidth - 2))
13089 End With
13090 curRI = RangeAddress_Parse(curCellAddress)
13099 curColNumString = Format$(curRI.ColLeft, "000")
13110 With curButton
13111 .Name = myMacroName & curColNumString
13112 .OnAction = myMacroName
13113 .Fill.Visible = msoFalse
13114 .Line.Visible = msoFalse
13115 .Placement = xlMoveAndSize
13119 End With
13120 With curUpArrow
13101 .Name = myMacroName & curColNumString & "Up"
13122 .Visible = msoFalse
'Arrows made visible/invisible by click event of the button.
13129 .Placement = xlMove
13130 With .Fill
13131 .Solid
13132 .ForeColor.SchemeColor = theArrowColor
13139 End With
13199 End With
13200 With curDownArrow
13201 .Name = myMacroName & curColNumString & "Dn"
13202 .Visible = msoFalse
'Arrows made visible/invisible by click event of the button.
13203 .Placement = xlMove
13209 .IncrementRotation 180
13211 With .Fill
13212 .Solid
13213 .ForeColor.SchemeColor = theArrowColor
13219 End With
13299 End With
13990 Next curCell
13991 End With
13999 End If
SortButtons_Create_xit:
DebugStackPop
On Error Resume Next
Set myRange = Nothing
Set curCell = Nothing
Set curButton = Nothing
Set curDownArrow = Nothing
Set curUpArrow = Nothing
Set myParentModule = Nothing
Set myCodeModule = Nothing
Set myWB = Nothing
Exit Sub
SortButtons_Create_err:
BugAlert True, "MacroName='" & myMacroName & "', FirstDataRow='" &
theRowNum_DataFirst & "', LastDataRow='" & theRowNum_DataLast & "'."
Resume SortButtons_Create_xit
End Sub
==============================================
The whole schmeer:
"sort" button to the top of each column.
Works fine locally or deployed over the LAN, but somebody's tripping
over it when run on a Citrix server.
Error# 1004: Programmatic access to Visual Basic Project is not
trusted
The lline of code in question:
--------------------------------------------------------
Dim myParentModule As VBComponent
13041 Set myParentModule =
myWB.VBProject.VBComponents.Add(vbext_ct_StdModule)
-------------------------------------------------------
VBComponent seems tb part of ...Program Files\Common Files\Microsoft
Shared\VBA\VBA6\VBE6EXT.OLB
"Seems" bc the path is too long to fit in the References dialog and
I'm winging it on the VBA6 part on.
Assuming I've got the .OLB right, does anybody know what's to be done
to make the problem go away? Something w/Citirx? Something w/
Windows Server?
For the masochistically-inclined, here's the whole schmeer:
==============================================
Public Sub SortButtons_Create(ByVal theRowNum_Buttons As Long, ByVal
theRowNum_DataFirst As Long, ByVal theRowNum_DataLast As Long, ByVal
theColNum_ButtonFirst As Long, ByVal theColNum_ButtonLast As Long,
ByVal theColNum_DataFirst As Long, ByVal theColNum_DataLast As Long,
ByVal theArrowColor As Long, ByRef theWS As Excel.Worksheet, Optional
theMacroName As String, Optional theColNum_SubTotals As Long, Optional
theSubTotals_Label As String)
13000 DebugStackPush mModuleName & ": SortButtons_Create"
13001 On Error GoTo SortButtons_Create_err
' PURPOSE: - To put a series of invisible rectangles on a
worksheet which, when clicked,
' call a routine that sorts the entire sheet's data on
that column's values.
' - To create up/down arrows to supplement the rectangles
by servint as visual indicator
' of what is sorted on and how
' - To create/install a macro named "SortSheet" that will
serve as the routine that sorts the sheet
' ACCEPTS: - Row number of the row to have the invisible
rectangles installed on it
' - Row number of the first row tb sorted
' - Row number of the last row tb sorted
' - Col number of first column that gets a button
' - Col number of last column that gets a button
' - Col number of first column tb sorted (generally
same as first col to get a button)
' - Col number of last column tb sorted (generally same
as last col to get a button)
' - Color tb used when drawing the Up/Down arrows. Must
be valid in Excel's scheme of things.
' e.g. 10 = Red
' - Pointer to the Excel.Worksheet where the buttons go
' - OPTIONAL name of sort macro name. TB used if/when
we need to install multiple
' macros in a single sheet - as with Market Value
Changes report, which has a
' separate macro for each report grouping.
' - OPTIONAL column number of label that identifies
subtotal lines (so they can be removed and
' not confuse the sort result)
' - OPTIONAL literal value of subtotal lines' label
'
' NOTES: 1) BEWARE OF Null CELLS. If a column on the sheet tb
sorted contains Null values,
' the Sort command will break down and the user will
not be able to flip-flop
' the direction. SO: For strings and dates, if the
cell were tb Null, you
' need to populate it with a space. For numerics, it
must be populated with
' zero. Let the formatting hide the zeros if the user
doesn't want to see them.
13002 Dim myWB As Excel.Workbook
Dim myRange As Excel.Range
Dim curCell As Excel.Range
Dim curButton As Shape
Dim curUpArrow As Shape
Dim curDownArrow As Shape
Dim myParentModule As VBComponent
Dim myCodeModule As CodeModule
Dim curRI As RangeInfo
Dim curCellAddress As String
Dim curColNumString As String
Dim myCode As String
Dim myMacroName As String
Dim okToSort As Boolean
Const myArrowHeight As Long = 5
Const myArrowWidth As Long = 5
Const myDefaultMacroName As String = "SortSheet" 'This value
is implicit in myCode1
' -----------------------------------------------------------
' We use these constants to assemble the macro tb added to the
SS
' which does the actual sorting
Const myCode01 As String = "Sub "
' concat myMacroName
Const myCode02 As String = _
"() " & vbCrLf & vbCrLf & _
"'PURPOSE: - To allow user to sort the entire sheet by
clicking on a column header" & vbCrLf & _
"' - To maintain visibility of up/down arrows
which indicate which cols are sorted and" & vbCrLf & _
"' the direction of the sort" & vbCrLf & _
"'" & vbCrLf & _
"' NOTES: 1) This routine's code was generated by the
same application" & vbCrLf & _
"' that created this spreadsheet. That is why
the data area's dimensions" & vbCrLf & _
"' are supplied via constants: the creating
app concatonated them into this code" & vbCrLf & _
"'
Pete Cresswell" & vbCrLf & _
"'
610-513-0066" & vbCrLf & _
" Dim myWS As Worksheet " &
vbCrLf & _
" Dim myRange As Range " &
vbCrLf & vbCrLf & _
" Dim i As Long " &
vbCrLf & _
" Dim R As Long " &
vbCrLf & _
" Dim topVal As String " &
vbCrLf & _
" Dim botVal As String " &
vbCrLf & _
" Dim okToSort As Boolean " &
vbCrLf & _
" Dim mySortCol As Long " &
vbCrLf & _
" Dim mySortOrder As Long " &
vbCrLf & _
" Dim myWeight As Long " &
vbCrLf & _
" Dim myLineStyle As Long " &
vbCrLf & _
" Dim myCallerName As String " &
vbCrLf & vbCrLf
Const myCode03 As String = _
" Static subTotals_Removed As Boolean " &
vbCrLf & _
" Static rowNum_LastData_Revised As Long " &
vbCrLf & vbCrLf & _
" Const rowNum_FirstData As Long = "
' concat theRowNum_DataFirst
Const myCode04 As String = " Const
rowNum_LastData As Long = "
Const myCode05 As String = " Const
colNum_FirstData As Long = "
Const myCode06 As String = " Const
colNum_LastData As Long = "
Const myCode07 As String = " Const
colNum_SubTotals As Long = "
Const myCode08 As String = " Const
subTotals_Label As String = """
Const myCode09 As String = _
" Set myWS = ActiveSheet " & vbCrLf & vbCrLf & _
"'
---------------------------------------------------------" & vbCrLf &
_
"' If creating routine has specified subtotals exist," &
vbCrLf & _
"' empty out entire line for each subtotal" & vbCrLf & _
"' " & vbCrLf & _
"' We *could* delete those lines, but that would
introduce" & vbCrLf & _
"' the complexities of adjusting boxes around data and
we" & vbCrLf & _
"' don't want to go there..." & vbCrLf & vbCrLf & _
" With myWS " & vbCrLf & _
" If subTotals_Removed = True Then
" & vbCrLf & _
" okToSort = True
" & vbLf & _
" Else
" & vbLf & _
" If MsgBox(""Sorting on this column will cause all
subtotals to be removed."" & vbLf & vbLf & ""Do you want to
continue?"", vbQuestion + vbYesNo) = vbYes Then" & vbCrLf & _
" rowNum_LastData_Revised = rowNum_LastData " &
vbCrLf & _
" If ((Len(subTotals_Label & """") > 0) And
(colNum_SubTotals > 0)) Then " & vbCrLf & _
"' First take care of last row if it is a
subtotal, preserving any bold bottom border" & vbCrLf & _
" R = rowNum_LastData_Revised " & vbCrLf & _
" If .Cells(R, colNum_SubTotals).Value =
subTotals_Label Then" & vbCrLf & _
" Set myRange = .Range(.Cells(R,
colNum_FirstData), .Cells(R, colNum_LastData))" & vbCrLf & _
" With myRange.Borders(xlEdgeBottom)" &
vbCrLf & _
" myWeight = .Weight" & vbCrLf & _
" myLineStyle = .LineStyle" & vbCrLf &
_
" End With"
Const myCode10 As String = _
" .Rows(rowNum_LastData_Revised).Delete" &
vbCrLf & _
" rowNum_LastData_Revised =
rowNum_LastData_Revised - 1" & vbCrLf & _
" R = rowNum_LastData_Revised" & vbCrLf & _
" Set myRange = .Range(.Cells(R,
colNum_FirstData), .Cells(R, colNum_LastData))" & vbCrLf & _
" With myRange.Borders(xlEdgeBottom)" &
vbCrLf & _
" .Weight = myWeight" & vbCrLf & _
" .LineStyle = myLineStyle" & vbCrLf &
_
" End With" & vbCrLf & _
" End If" & vbCrLf & vbCrLf & _
"' Now deal with all the other subtotals " &
vbCrLf & _
" For R = rowNum_FirstData To
rowNum_LastData" & vbCrLf & _
" If .Cells(R, colNum_SubTotals).Value =
subTotals_Label Then " & vbCrLf & _
" .Rows(R).Delete Shift:=xlDown " &
vbCrLf & _
" rowNum_LastData_Revised =
rowNum_LastData_Revised - 1 " & vbCrLf & _
" End If " & vbCrLf & _
" Next R " & vbCrLf & _
" subTotals_Removed = True " & vbCrLf & _
" Else " & vbCrLf & _
" subTotals_Removed = True " & vbCrLf & _
" End If" & vbCrLf & _
" okToSort = true" & vbCrLf & _
" End If" & vbCrLf & _
" End If" & vbCrLf & _
" End With " & vbCrLf & vbCrLf
Const myCode11 As String = _
"'
--------------------------------------------------------- " & vbCrLf &
_
"' Do the sorting thing..." & vbCrLf & vbCrLf & _
" if okToSort = true then " & vbCrLf & _
" With myWS " & vbCrLf & _
" myCallerName = .Shapes(Application.Caller).Name"
& vbCrLf & vbCrLf & _
" For i = colNum_FirstData To colNum_LastData" &
vbCrLf & _
" On Error Resume Next 'User may have
deleted 1 or more columns" & vbCrLf & _
" .Shapes("""
'Concat mymacroname
Const myCode12 As String = _
""" & Format$(i, ""000"") &
""Up"").Visible = False" & vbCrLf & _
" .Shapes("""
'Concat mymacroname
Const myCode13 As String = _
""" & Format$(i, ""000"") &
""Dn"").Visible = False" & vbCrLf
Const myCode14 As String = _
" On Error GoTo 0 " & vbCrLf & _
" Next i" & vbCrLf & vbCrLf & _
" mySortCol
= .Shapes(Application.Caller).TopLeftCell.Column " & vbCrLf & _
" Set myRange = .Range(.Cells(rowNum_FirstData,
colNum_FirstData), .Cells(rowNum_LastData_Revised, colNum_LastData)) "
& vbCrLf & vbCrLf
Const myCode15 As String = _
" topVal = uCase$(.Cells(rowNum_FirstData,
mySortCol).Value) " & vbCrLf & _
" botVal = uCase$(.Cells(rowNum_LastData_Revised,
mySortCol).Value) " & vbCrLf & _
"
" & vbCrLf & _
" If topVal < botVal
Then " & vbCrLf &
_
" mySortOrder =
xlDescending " & vbCrLf
& _
" On Error Resume Next 'User may have
deleted one or more arrows " & vbCrLf & _
" .Shapes(myCallerName & ""Dn"").Visible =
True " & vbCrLf & _
" On Error GoTo
0 " & vbCrLf
& _
"
Else
" & vbCrLf & _
" mySortOrder =
xlAscending " & vbCrLf
& _
" On Error Resume
Next " & vbCrLf &
_
" .Shapes(myCallerName & ""Up"").Visible =
True " & vbCrLf & _
" On Error GoTo
0 " & vbCrLf
& _
" End
If
" & vbCrLf & vbCrLf & _
" myRange.Sort key1:=.Cells(rowNum_FirstData,
mySortCol), order1:=mySortOrder " & vbCrLf & _
" End
With
" & vbCrLf & _
" End
If
" & vbCrLf & _
" End
Sub
"
'
------------------------------------------------------------------------
' If there are not multiple data rows specified or if there are no
data columns
' specified, call the whole thing off.
13010 If Abs((theRowNum_DataLast - theRowNum_DataFirst)) > 0 Then
13011 If Abs((theColNum_ButtonLast - theColNum_ButtonFirst)) > 0
Then
13012 okToSort = True
13013 End If
13019 End If
13020 If okToSort = True Then
'
------------------------------------------------------------------------
' Check to see if we have a special macro name
13030 If Len(theMacroName & "") = 0 Then
13031 myMacroName = myDefaultMacroName
13032 Else
13033 myMacroName = theMacroName
13039 End If
'
------------------------------------------------------------------------
' Create a code module in the target spreadsheet
' that will hold the code to handle our button click events
13040 Set myWB = theWS.Parent
13041 Set myParentModule =
myWB.VBProject.VBComponents.Add(vbext_ct_StdModule)
'13041 Set myParentModule =
myWB.VBProject.VBComponents("ThisWorkBook")
13049 Set myCodeModule = myParentModule.CodeModule
13050 myCode = myCode01 & myMacroName & _
myCode02 & vbCrLf & _
myCode03 & theRowNum_DataFirst & vbCrLf & _
myCode04 & theRowNum_DataLast & vbCrLf & _
myCode05 & theColNum_ButtonFirst & vbCrLf & _
myCode06 & theColNum_DataLast & vbCrLf & _
myCode07 & Val(theColNum_SubTotals & "") &
vbCrLf & _
myCode08 & theSubTotals_Label & Chr$(34) &
vbCrLf & _
myCode09 & vbCrLf & _
myCode10 & _
myCode11 & myMacroName & _
myCode12 & myMacroName & _
myCode13 & _
myCode14 & _
myCode15
13060 With myCodeModule
13061 .InsertLines .CountOfLines + 1, myCode
13069 End With
'
------------------------------------------------------------------------
' Now that we've got our macro code installed in the target Excel
workbook,
' we loop through the worksheet's columns, creating a rectangle/
button
' and a couple of directional indicator arrows in each column
header cell
' NB: If the text in a column header is right-justified, you'll
need to
' have done a .IndentLevel=1 to slide it over far enough so
the Up/Down
' arrows do not conflict with it
13070 With theWS
13071 Set myRange = .Range(.Cells(theRowNum_Buttons,
theColNum_ButtonFirst), .Cells(theRowNum_Buttons,
theColNum_ButtonLast))
13079 For Each curCell In myRange.Cells
13080 With curCell
13081 curCellAddress = .Address(ReferenceStyle:=xlR1C1)
13084 Set curButton
= .Parent.Shapes.AddShape(Type:=msoShapeRectangle, Top:=.Top,
Height:=.Height, Width:=.Width, Left:=.Left)
13085 Set curUpArrow
= .Parent.Shapes.AddShape(Type:=msoShapeIsoscelesTriangle, Top:=(.Top
+ .Height - myArrowHeight - 4), Height:=myArrowHeight,
Width:=myArrowWidth, Left:=(.Left + .Width - myArrowWidth - 2))
13086 Set curDownArrow
= .Parent.Shapes.AddShape(Type:=msoShapeIsoscelesTriangle, Top:=(.Top
+ .Height - myArrowHeight - 4), Height:=myArrowHeight,
Width:=myArrowWidth, Left:=(.Left + .Width - myArrowWidth - 2))
13089 End With
13090 curRI = RangeAddress_Parse(curCellAddress)
13099 curColNumString = Format$(curRI.ColLeft, "000")
13110 With curButton
13111 .Name = myMacroName & curColNumString
13112 .OnAction = myMacroName
13113 .Fill.Visible = msoFalse
13114 .Line.Visible = msoFalse
13115 .Placement = xlMoveAndSize
13119 End With
13120 With curUpArrow
13101 .Name = myMacroName & curColNumString & "Up"
13122 .Visible = msoFalse
'Arrows made visible/invisible by click event of the button.
13129 .Placement = xlMove
13130 With .Fill
13131 .Solid
13132 .ForeColor.SchemeColor = theArrowColor
13139 End With
13199 End With
13200 With curDownArrow
13201 .Name = myMacroName & curColNumString & "Dn"
13202 .Visible = msoFalse
'Arrows made visible/invisible by click event of the button.
13203 .Placement = xlMove
13209 .IncrementRotation 180
13211 With .Fill
13212 .Solid
13213 .ForeColor.SchemeColor = theArrowColor
13219 End With
13299 End With
13990 Next curCell
13991 End With
13999 End If
SortButtons_Create_xit:
DebugStackPop
On Error Resume Next
Set myRange = Nothing
Set curCell = Nothing
Set curButton = Nothing
Set curDownArrow = Nothing
Set curUpArrow = Nothing
Set myParentModule = Nothing
Set myCodeModule = Nothing
Set myWB = Nothing
Exit Sub
SortButtons_Create_err:
BugAlert True, "MacroName='" & myMacroName & "', FirstDataRow='" &
theRowNum_DataFirst & "', LastDataRow='" & theRowNum_DataLast & "'."
Resume SortButtons_Create_xit
End Sub
==============================================
The whole schmeer: