Hi,

I want to create (via programmation) the declaration of some variables in
the declaration part of an existing module and also a new procedure in the
same module. Once done, I would like to run that procedure by clicking on a
button in an already open and running UserForm.

Thanks for your help.

Pierre

Per Pierre Archambault:
Hi,

I want to create (via programmation) the declaration of some variables in
the declaration part of an existing module and also a new procedure in the
same module. Once done, I would like to run that procedure by clicking on a
button in an already open and running UserForm.

Thanks for your help.

Pierre


This is wretched excess, but I'm too lazy to tease out the
relevant code.

Find the routine "SortButtons_Create" and follow the code from
there.

If the NG text wrapping is too bad, flip me an email at
firstname fullstop lastname atsign fatbelly fullstopcom
and I'll email you a .bas file.

================================================== ==========
Option Compare Database
Option Explicit

' This module contains code used to create the Excel
spreadsheet-based reports
' It requires a Reference to 'Microsoft Excel 9.0 Object
Library'.

Const mModuleName = "basExcel"

'Next available line# series = 15000...

Global gExcelApp As excel.Application 'dummy pointer for use
in testing

Global Const gExcelConstant_Shape_Rectangle As Long =
1
Global Const gExcelConstant_TextOrientation_Horizontal As Long =
1

Const mExcelWorkSheetNameLen_Lim As Long =
29 'Error 1004 says 31, but experimentatins seems to indicate
29 is the actual limit

Global Const gExcelColor_BriteRed As Long =
10
Global Const gExcelColor_Green As Long =
14
Global Const gExcelColor_Grey_25Percent As Long =
15
Global Const gExcelColor_LimeGreen As Long =
35
Global Const gExcelColor_MediumYellow As Long =
36
Global Const gExcelColor_MediumBlue As Long =
37
Global Const gExcelColor_Lavender As Long =
39
Global Const gExcelColor_Peach As Long =
40
Global Const gExcelColor_YellowDark As Long =
44
Global Const gExcelColor_Tangerine_Darker As Long =
46
Global Const gExcelColor_DarkBlue As Long =
49

Global Const gExcel_MaxCols As Long =
256

Public Type PageSetupInfo
BlackAndWhite As String
BottomMarginInches As Double
CenterHorizontally As String
CenterVertically As String
Draft As String
FirstPageNumber As String
FitToPagesTall As Long
FitToPagesWide As Long
Header_Left As String
Header_Right As String
Header_Center As String
Header_MarginInches As String
Footer_Left As String
Footer_Right As String
Footer_Center As String
Footer_MarginInches As String
LeftMarginInches As Double
Order As String
Orientation As String
PageOrder As String
PaperSize As String
PercentPageSize As Double
PrintArea As String
PrintComments As String
PrintGridlines As String
PrintHeadings As String
PrintQuality As String
RightMarginInches As Double
' ScalingFactor As String ' "{2,3}" indicates 2 pages
wide and 3 pages tall, but we concoct this from
..FitToPagesWide/Tall
TopMarginInches As Double
Zoom As Double ' Mutually exclusive with
FItToPagesTall/..Wide. If present, sets page to, say, 60% of
normal
End Type

Public Sub Excel_Kill()
debugStackPush mModuleName & ": Excel_Kill"
On Error GoTo Excel_Kill_err

' PURPOSE: To shut down whatever instance of Excel the global
variable is pointing to

Const objectNotSet = 91

gExcelApp.Quit
Set gExcelApp = Nothing

Excel_Kill_xit:
DebugStackPop
On Error Resume Next
Exit Sub

Excel_Kill_err:
Select Case Err
Case objectNotSet
'Do nothing, no Excel app is on the other end
Case Else
BugAlert True, ""
End Select
Resume Excel_Kill_xit
End Sub
Public Function SpreadSheetOpen_Existing(ByVal theSsPath As
String, ByRef theSS As excel.Application) As Boolean
3000 debugStackPush mModuleName & ": SpreadSheetOpen_Existing: "
3001 On Error GoTo SpreadSheetOpen_Existing_err

' PURPOSE: - Start an instance of MS Excel or use an existing
instance
' - Leave "theSS" pointing to the Excel Basic engine
' behind the newly-opened document
' ACCEPTS: - Path to the spreadsheet file
' - Pointer to the spreadsheet TB used by calling
routine
' RETURNS: True/False depending on success
'
' NOTES: 1) We do not want to keep opening up new instances
of Excel every time this routine
' is called, so we do the "= Nothing" check to see
if theSS has already been set.
' OTHO the user may have closed that instance of
Excel, leaving theSS pointing to
' Neverneverland. Experimentation shows that an
error 2753 is generated in this case.
' Hence the error trap and the "userClosedExcel"
switch.
'
'SAMPLE:
'
?SpreadSheetOpenExisting("D:\Dev\SEI\DataSource\Bu ySell.xls",
gExcelApp)

3002 Dim userClosedExcel As Long
Dim serverNotExist As Long
Dim okToProceed As Boolean

Const oleError = 2753
Const rpcServerUnavailable = -2147023174
Const remoteServerNotExist = 462
Const docAlreadyOpen = 1004

3010 DoCmd.Hourglass True

SpreadSheetOpen_Existing_loop:
' ---------------------------------------------------
' Create an instance of Excel

3100 If (theSS Is Nothing) Or (userClosedExcel = 1) Then
3110 Set theSS = CreateObject("Excel.Application")
3120 End If


' ---------------------------------------------------
' Open up the spreadsheet

3150 With theSS
3151 .Workbooks.Open Filename:=theSsPath, UpdateLinks:=0
3152 .ScreenUpdating = True
3154 .Visible = False
3158 End With

3999 SpreadSheetOpen_Existing = True

SpreadSheetOpen_Existing_xit:
DoCmd.Hourglass False
DebugStackPop
On Error Resume Next
Exit Function

SpreadSheetOpen_Existing_err:
Select Case Err
Case 2772
MsgBox "Unable to locate Microsoft Excel program. Please
notify your administrator", 16, "Cannot Open MS Excel"
Resume SpreadSheetOpen_Existing_xit
Case oleError, rpcServerUnavailable
If userClosedExcel = 0 Then
userClosedExcel = userClosedExcel + 1
Resume SpreadSheetOpen_Existing_loop
Else
BugAlert True, "Unable to open MS Excel. Suspect
user may have closed existing instance."
Resume SpreadSheetOpen_Existing_xit
End If
Case remoteServerNotExist
If serverNotExist = 0 Then
serverNotExist = serverNotExist + 1
Set theSS = Nothing
Resume SpreadSheetOpen_Existing_loop
Else
BugAlert True, "Unable to open MS Excel. Suspect
user may have closed existing instance."
Resume SpreadSheetOpen_Existing_xit
End If

Case docAlreadyOpen
BugAlert True, ""

Case Else
BugAlert True, ""
Resume SpreadSheetOpen_Existing_xit
End Select
Resume SpreadSheetOpen_Existing_xit 'Shouldn't be
needed, but just in case.....
End Function
Public Function SpreadSheetOpen_New(ByVal theVisibilitySwitch As
Boolean, ByRef theSS As excel.Application) As Boolean
3000 debugStackPush mModuleName & ": SpreadSheetOpen_New: "
3001 On Error GoTo SpreadSheetOpen_New_err

' PURPOSE: - Start an instance of MS Excel or use an existing
instance
' - Leave "theSS" pointing to the Excel Basic engine
' behind the newly-opened document
' ACCEPTS: - Switch telling whether the spreadsheet sb made
visible to user
' - Pointer to the spreadsheet object tb used by
calling routine
' RETURNS: True/False depending on success
'
' NOTES: 1) We do not want to keep opening up new instances
of Excel every time this routine
' is called, so we do the "= Nothing" check to see
if theSS has already been set.
' OTHO the user may have closed that instance of
Excel, leaving theSS pointing to
' Neverneverland. Experimentation shows that an
error 2753 is generated in this case.
' Hence the error trap and the "userClosedExcel"
switch.

3002 Dim userClosedExcel As Long
Dim serverNotExist As Long
Dim okToProceed As Boolean
Dim rorFunctionLibraryPath As String

Const oleError = 2753
Const rpcServerUnavailable = -2147023174
Const remoteServerNotExist = 462
Const docAlreadyOpen = 1004

3010 DoCmd.Hourglass True
3011 rorFunctionLibraryPath = TempPath_Get() & "\FUNCTION.xla"
'Determined by Returns_Go_2.txt (which becomes Returns_Go_2.BAT
during initial execution)


SpreadSheetOpen_New_loop:
' ---------------------------------------------------
' Create an instance of Excel

3100 If (theSS Is Nothing) Or (userClosedExcel = 1) Then
3110 Set theSS = CreateObject("Excel.Application")
3120 End If

' ---------------------------------------------------
' - Open up the new spreadsheet
' - Make sure Function.xla is available (so that users
' can invoke the ROR() calculation)

3150 With theSS
'3151 .Workbooks.Add
3152 .ScreenUpdating = True
3153 .Visible = theVisibilitySwitch
3159 End With

3999 SpreadSheetOpen_New = True

SpreadSheetOpen_New_xit:
DoCmd.Hourglass False
DebugStackPop
On Error Resume Next
Exit Function

SpreadSheetOpen_New_err:
Select Case Err
Case 2772
MsgBox "Unable to locate Microsoft Excel program. Please
notify your administrator", 16, "Cannot Open MS Excel"
Resume SpreadSheetOpen_New_xit
Case oleError, rpcServerUnavailable
If userClosedExcel = 0 Then
userClosedExcel = userClosedExcel + 1
Resume SpreadSheetOpen_New_loop
Else
BugAlert True, "Unable to open MS Excel. Suspect
user may have closed existing instance."
Resume SpreadSheetOpen_New_xit
End If
Case remoteServerNotExist
If serverNotExist = 0 Then
serverNotExist = serverNotExist + 1
Set theSS = Nothing
Resume SpreadSheetOpen_New_loop
Else
BugAlert True, "Unable to open MS Excel. Suspect
user may have closed existing instance."
Resume SpreadSheetOpen_New_xit
End If

Case docAlreadyOpen
BugAlert True, ""

Case Else
BugAlert True, ""
Resume SpreadSheetOpen_New_xit
End Select
Resume SpreadSheetOpen_New_xit 'Shouldn't be needed,
but just in case.....
End Function
Public Sub Excel_PageSetup(ByVal theWorksheetName As String,
ByRef thePSI As PageSetupInfo, ByRef theSS As excel.Application)
9000 debugStackPush mModuleName & ": Excel_PageSetup"
9001 On Error GoTo Excel_PageSetup_err

' PURPOSE: To alter the Page Setup info of an Excel
spreadsheet in a more timely fashion than
' just using PageSetup.xxx - which is painfully slow
' ACCEPTS: - Name of the worksheet for which we are doing the
setup
' - Pointer to struct containing any parms we want to
set
' - Reference to the Excel spreadsheet in question
'
' NOTES: 1) This is a kludge in that it uses the old Excel 4
macro language.
' Clearly it will break if/when Excel loses
backward compatability.
' 2) Full syntax of the Excel4 Macro:
' PAGE.SETUP(HeaderText,
' FooterText, 'Text and
formatting codes for the workbook footer.
' LeftMargin, 'Corresponds to
the Left box and is a number specifying the left margin.
' RightMargin, 'Corresponds to
the Right box and is a number specifying the right margin.
' TopMargin, 'Corresponds to
the Top box and is a number specifying the top margin.
' BotMargin, 'Corresponds to
the Bottom box and is a number specifying the bottom margin.
' PrintHeadings, 'Corresponds to
the Row & Column Headings check box. Hdng is available only in
the sheet and macro sheet form of the function.
' PrintGridLines, 'Corresponds to
the Cell Gridlines check box. Grid is available only in the sheet
and macro sheet form of the function.
' CenterHorizontally, 'Corresponds to
the Center Horizontally check box in the Margins panel of the
Page Setup dialog box.
' CenterVertically, 'Corresponds to
the Center Vertically check box in the Margins panel of the Page
Setup dialog box.
' Orientation, 'Determines the
direction in which your workbook is printed.
' PaperSize, 'A number from 1
to 26 that specifies the size of the paper.
' scale, 'E.G. "{2,3}"
indicates 2 pages wide and 3 pages tall. We concoct this by
concatting the input struct's .FitToPagesWide and .FitToPagesTall
' FirstPageNumber, 'The number of
the first page. If zero, sets first page to zero. If "Auto" is
used, then the page numbering is set to automatic. If omitted,
PAGE.SETUP retains the existing pg_num.
' PageOrder 'Specifies
whether pagination is left-to-right and then down, or
top-to-bottom and then right.
' BwCells, 'A logical value
that specifies whether to print cells and all graphic objects,
such as text boxes and buttons, in color.
' ' - If BwCells
is TRUE, Microsoft Excel prints cell text and borders in black
and cell backgrounds in white.
' ' - If BwCells
is FALSE , Microsoft Excel prints cell text, borders, and
background patterns in color (or in gray scale).
' PrintQuality, ' Specifies the
print quality in dots-per-inch. To specify both horizontal and
vertical print quality, use an array of two values.
' HeaderMarginInches, 'The placement,
in inches, of the running head margin from the edge of the page.
' FooterMarginInches, 'Placement, in
inches, of the running foot margin from the edge of the page.
' PrintComments, 'Specifies
whether to print cell notes with the sheet. If TRUE, both the
sheet and the cell notes are printed. If FALSE or omitted, just
the sheet is printed.
' DraftPrintingMode 'Corresponds to
the Draft Quality checkbox in the Sheet tab and in the Chart tab
of the Page Setup dialog box. If FALSE or omitted, graphics are
printed with the sheet. If TRUE, no graphics are printed.
' )

9002 Dim myHeader As String
Dim myFooter As String
Dim myPageSetupString As String
Dim myScale As String

Const myComma = ","

' ---------------------------------------------------------
' Unload some the struct's data into local variables

9010 With thePSI
'9011 If .Header_Left < "" Then 'Setting
..Header doesn't seem to work, so we do .Left, .Right, and .Center
'9012 myHeader = "&L" & .Header_Left 'at the very
end - going directly to the .PageSetup object
'9019 End If
'
'9020 If .Header_Center < "" Then
'9021 myHeader = myHeader & "&C" & .Header_Center
'9029 End If
'
'9030 If .Header_Right < "" Then
'9031 myHeader = myHeader & "&R" & .Header_Right
'9039 End If

9040 If Not myHeader = "" Then
9041 myHeader = """" & myHeader & """"
9049 End If

9050 If .Footer_Left < "" Then
9051 myFooter = "&L" & .Footer_Left
9059 End If

9060 If .Footer_Center < "" Then
9061 myFooter = myFooter & "&C" & .Footer_Center
9069 End If

9070 If .Footer_Right < "" Then
9071 myFooter = myFooter & "&R" & .Footer_Right
9079 End If

9080 If ((.FitToPagesWide 0) And (.FitToPagesTall 0)) Then
9081 myScale = "{" & .FitToPagesWide & "," &
..FitToPagesTall & "}"
9082 Else
9083 If .Zoom 0 Then
9084 myScale = .Zoom
9085 End If
9089 End If
9299 End With

9310 If Not myFooter = "" Then
9311 myFooter = """" & myFooter & """"
9319 End If

' ---------------------------------------------------------
' Using a combination of our local variables and direct refs
' to the struct, build our PAGE.SETUP macro call
' inchesToPoints(.LeftMarginInches) & myComma & _
' inchesToPoints(.RightMarginInches) & myComma & _
' inchesToPoints(.TopMarginInches) & myComma & _
' inchesToPoints(.BottomMarginInches) & myComma & _

9320 With thePSI
9330 myPageSetupString = "PAGE.SETUP" & _
"(" & _
myHeader & myComma & _
myFooter & myComma & _
.LeftMarginInches & myComma & _
.RightMarginInches & myComma & _
.TopMarginInches & myComma & _
.BottomMarginInches & myComma & _
.PrintHeadings & myComma & _
.PrintGridlines & myComma & _
.CenterHorizontally & myComma & _
.CenterVertically & myComma & _
.Orientation & myComma & _
.PaperSize & myComma & _
myScale & myComma & _
.FirstPageNumber & myComma & _
.PageOrder & myComma & _
.BlackAndWhite & myComma & _
.PrintQuality & myComma & _
.Header_MarginInches & myComma & _
.Footer_MarginInches & myComma & _
.PrintComments & myComma & _
.Draft & _
")"
9399 End With

' ---------------------------------------------------------
' Invoke the macro using the call we just concocted

9400 theSS.ExecuteExcel4Macro myPageSetupString

' ---------------------------------------------------------
' Apply some props that we don't know how to set via
' the macro kludge above - or which are giving us trouble

9500 With theSS.Worksheets(theWorksheetName).PageSetup

' -----------------------------------
' Here, it gets a little weird.
' If the calling routine set .FitToPages...,
' it left .Zoom unset and, preseumabley, zero
' This worked find for awhile, and then one day
' .FitToPages started getting overriden by a
' .Zoom=100 - even though we never set it.
' We trid setting .Zoom = thePSI.Zoom, but it
' failed. Setting it to False, however, worked.
' Go figure....

9501 If thePSI.Zoom = 0 Then
9502 .Zoom = False
9503 Else
9504 .Zoom = thePSI.Zoom
9509 End If
' -----------------------------------

9540 .PrintArea = thePSI.PrintArea

9570 If Len(thePSI.Header_Left & "") 0 Then
9571 .LeftHeader = thePSI.Header_Left
9579 End If

9560 If Len(thePSI.Header_Center & "") 0 Then
9561 .CenterHeader = thePSI.Header_Center
9569 End If

' ----------------------------------------
' These parms seemed tb working for awhile, but
' when in testing, they appeared not tb working
' via Excel4.PAGE.SETUP - so we are doing a
' workaround by going directly to the driver

9910 If Len(thePSI.Header_Right & "") 0 Then
9911 .RightHeader = thePSI.Header_Right
9919 End If

9920 .PaperSize = thePSI.PaperSize

'9930 .leftMargin = thePSI.LeftMarginInches
'9931 .RightMargin = thePSI.RightMarginInches
'9932 .topMargin = thePSI.TopMarginInches
'9939 .bottomMargin = thePSI.BottomMarginInches
9969 End With

Excel_PageSetup_xit:
DebugStackPop
On Error Resume Next
Exit Sub

Excel_PageSetup_err:
BugAlert True, ""
Resume Excel_PageSetup_xit
End Sub
Public Function WorkSheetName_Legal_FundNameTrancheNumber(ByVal
theDealName As String, theTrancheNumber As String, ByRef theWB As
excel.Workbook) As String
debugStackPush mModuleName & ":
WorkSheetName_Legal_FundNameTrancheNumber"
On Error GoTo WorkSheetName_Legal_FundNameTrancheNumber_Err

' PURPOSE: To concoct a worksheet name that Excel will accept out
of a
' Deal name and a Tranche Number
' ACCEPTS: - The string to be converted
' - Pointer to the workbook where the sheet bearing the
proposed name
' will reside
' RETURNS: - A string with any illegal characters replaced with
underscores
'
' NOTES: 1) The source for our logic is the following error -
thrown when
' we try to add an illegal name
'
-----------------------------------------------------------------
' Error 1004: While renaming a sheet or chart, you
entered an invalid name.
' Try one of the following:
' • Make sure the name you entered does
not exceed 31 characters.
' • Make sure the name does not contain
any of the following characters: : \ / ? * [ or ]
' • Make sure you did not leave the name
blank.
' 2) We do not touch the tranche number. Reason: if a
deal with a long name has
' multiple tranches with similar names, we do not
want to run the risk of creating
' duplicate worksheet names. As it is,
TrancheNumber sb unique within a deal and
' we will always come up with the same abbreviated
version of the deal name


Dim myDealName As String
Dim myTrancheNumber As String
Dim myWorkSheetName As String
Dim myCharsAvailable As Long

Const myDelimiter As String = "-"

myDealName = theDealName
myTrancheNumber = theTrancheNumber


' ----------------------------------------
' Replace any illegal characters with a harmless characther

myDealName = worksheetName_LegalChars(myDealName)
myTrancheNumber = worksheetName_LegalChars(myTrancheNumber)

' ----------------------------------------
' Concatonate Deal|Delimiter|Tranche to make name

myWorkSheetName = myDealName & myDelimiter & myTrancheNumber

' ----------------------------------------
' If the name is too long right-trunc the Dealname to make the
' whole name a legal length

If Len(myWorkSheetName) mExcelWorkSheetNameLen_Lim Then
myCharsAvailable = mExcelWorkSheetNameLen_Lim -
Len(myTrancheNumber) - Len(myDelimiter)
myWorkSheetName = Left$(myDealName, myCharsAvailable) &
myDelimiter & myTrancheNumber
End If

' ----------------------------------------
' Finally, make sure that the name is unique, replacing
' the last few chars with a sequence number if it is not

myWorkSheetName = worksheetName_Unique(myWorkSheetName, theWB)

' ----------------------------------------
' Return the name

WorkSheetName_Legal_FundNameTrancheNumber = myWorkSheetName

WorkSheetName_Legal_FundNameTrancheNumber_xit:
DebugStackPop
On Error Resume Next
Exit Function

WorkSheetName_Legal_FundNameTrancheNumber_Err:
BugAlert True, ""
Resume WorkSheetName_Legal_FundNameTrancheNumber_xit
End Function
Public Function WorkSheetName_Legal(ByVal theNameRaw As String,
ByRef theWB As excel.Workbook) As String
10000 debugStackPush mModuleName & ": WorkSheetName_Legal"
10001 On Error GoTo WorkSheetName_Legal_Err

' PURPOSE: To make sure that a proposed worksheet name is
legal per Excel's standards
' ACCEPTS: - The string to be converted
' - Pointer to the workbook where the sheet bearing
the proposed name
' will reside
' RETURNS: - A string shortened to Excel's limit with any
illegal
' characters replaced by underscores
'
' NOTES: 1) The source for our logic is the following error
- thrown when
' we try to add an illegal name
'
-----------------------------------------------------------------
' Error 1004: While renaming a sheet or chart,
you entered an invalid name.
' Try one of the following:
' • Make sure the name you entered
does not exceed 31 characters.
' • Make sure the name does not
contain any of the following characters: : \ / ? * [ or ]
' • Make sure you did not leave the
name blank.


10002 Dim myWorkSheetName As String
Dim myRemainder As Long

' ----------------------------------------
' Replace any illegal characters with a harmless characther

10020 myWorkSheetName = theNameRaw
10022 myWorkSheetName = worksheetName_LegalChars(myWorkSheetName)

' ----------------------------------------
' If the name is too long right-trunc it to allowed length

10030 If Len(myWorkSheetName) mExcelWorkSheetNameLen_Lim Then
10031 myWorkSheetName = Left$(myWorkSheetName,
mExcelWorkSheetNameLen_Lim)
10039 End If

' ----------------------------------------
' Finally, make sure that the name is unique, replacing
' the last few chars with a sequence number if it is not

10050 myWorkSheetName = worksheetName_Unique(myWorkSheetName,
theWB)

' ----------------------------------------
' Return the name

10999 WorkSheetName_Legal = myWorkSheetName

WorkSheetName_Legal_xit:
DebugStackPop
On Error Resume Next
Exit Function

WorkSheetName_Legal_Err:
BugAlert True, ""
Resume WorkSheetName_Legal_xit
End Function
Private Function worksheetName_Unique(ByVal theName As String,
ByRef theWB As excel.Workbook) As String
11000 debugStackPush mModuleName & ": worksheetName_Unique"
11001 On Error GoTo worksheetName_Unique_err

' PURPOSE: To ensure that a proposed worksheet name will be
unique within a given workbook
' ACCEPTS: - Proposed name
' - Pointer to the Excel Workbook object that the
worksheet will be part of
' RETURNS: A name that is guaranteed tb unique - albeit maybe
truncated by a few chars
' with a sequence# appended

11002 Dim myWS As excel.Worksheet

Dim k As Long
Dim myName As String
Dim mySuffix As String
Dim gotError As Boolean
Dim gotGoodName As Boolean

11010 myName = theName

11020 Do
1129 gotGoodName = Not worksheet_Exist(myName, theWB)
11030 If gotGoodName = False Then
11031 k = k + 1
11032 mySuffix = Format$(k, "#0")
11033 myName = Left(theName, mExcelWorkSheetNameLen_Lim -
Len(mySuffix)) & mySuffix
11039 End If
11099 Loop Until gotGoodName = True

11999 worksheetName_Unique = myName

worksheetName_Unique_xit:
DebugStackPop
On Error Resume Next
Exit Function

worksheetName_Unique_err:
BugAlert True, ""
Resume worksheetName_Unique_xit
End Function
Private Function worksheet_Exist(ByVal theWorksheetName As
String, ByRef theWB As excel.Workbook) As Boolean
debugStackPush mModuleName & ": worksheet_Exist"
On Error GoTo worksheet_Exist_err

' PURPOSE: To determine if a worksheet of a given name exists in
a specified workbook
' ACCEPTS - Name of the worksheet in question
' - Pointer to the workbook we want to check
' RETURNS: True if the sheet exists, else False
'
' NOTES: 1) We got into trouble trying to do it the easy way:
namely
' just trying to set a WorkSheet pointer to the name
' in question and checking .Err.

Dim k As Long
Dim i As Long

k = theWB.Worksheets.Count

If k 0 Then
For i = 1 To k
If theWB.Worksheets(i).Name = theWorksheetName Then
worksheet_Exist = True
End If
Next i
End If

worksheet_Exist_xit:
DebugStackPop
On Error Resume Next
Exit Function

worksheet_Exist_err:
BugAlert True, ""
Resume worksheet_Exist_xit
End Function
Private Function worksheetName_LegalChars(ByVal theName As
String) As String
debugStackPush mModuleName & ": worksheetName_LegalChars"
On Error GoTo worksheetName_LegalChars_err

' PURPOSE: To replace any characters that are not legal for a
worksheet name
' ACCEPTS: Proposed name
' RETURNS: Proposed name with any illegal chars replaced

Dim myBadBoyz() As Variant

Dim i As Long
Dim myName As String
Dim myArraySize As Long

Const myBenignChar As String = "_"


myName = theName

' ----------------------------------------
' Create an array of illegal characters

myBadBoyz = Array(":", "\", "/", "?", "*", "[", "]", "^")
myArraySize = UBound(myBadBoyz)

' ----------------------------------------
' Replace any illegal characters with a harmless characther

For i = 0 To myArraySize
myName = Replace(myName, myBadBoyz(i), myBenignChar)
Next i

' ----------------------------------------
' Return the name with any bad chars replaced

worksheetName_LegalChars = myName

worksheetName_LegalChars_xit:
DebugStackPop
On Error Resume Next
Exit Function

worksheetName_LegalChars_err:
BugAlert True, ""
Resume worksheetName_LegalChars_xit
End Function
Private Function inchesToPoints(theInches As Double) As Long
debugStackPush mModuleName & ": inchesToPoints"
On Error GoTo inchesToPoints_err

' PURPOSE: To convert inches to points withoug the like-named
function from Excel
' ACCEPTS: Number of inches
' RETURNS: Equivalent of inches expressed as points

Const myPointsPerInch = 72

inchesToPoints = theInches * myPointsPerInch

inchesToPoints_xit:
DebugStackPop
On Error Resume Next
Exit Function

inchesToPoints_err:
BugAlert True, ""
Resume inchesToPoints_xit
End Function
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)
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.
'
' 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 myMacroCode As String
Dim myMacroName As String
Dim okToProceed As Boolean

Const myArrowHeight As Long = 5
Const myArrowWidth As Long = 5

Const myDefaultMacroName As String = "SortSheet" 'This
value is implicit in myMacroCode1

'
-----------------------------------------------------------
' We use these constants to assemble the macro tb added to
the SS
' which does the actual sorting

Const myMacroCode01 As String = "Sub "
Const myMacroCode02 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 (""CDO"")" & 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 mySortCol As Long " & vbCrLf & _
" Dim mySortOrder As Long " & vbCrLf & _
" Dim myCallerName as string " & vbCrLf &
vbCrLf & _
" Const rowNum_FirstData As Long = "

Const myMacroCode03 As String = " Const
rowNum_LastData As Long = "
Const myMacroCode04 As String = " Const
colNum_FirstData As Long = "
Const myMacroCode05 As String = " Const
colNum_LastData As Long = "

Const myMacroCode06 As String = _
" Set myWS = ActiveSheet " & vbCrLf & 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 myMacroCode07 As String = _
""" & Format$(i, ""000"") &
""Up"").Visible = False" & vbCrLf & _
" .Shapes("""

'Concat mymacroname

Const myMacroCode08 As String = _
""" & Format$(i, ""000"") &
""Dn"").Visible = False" & vbCrLf

Const myMacroCode09 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, colNum_LastData)) " &
vbCrLf & vbCrLf

Const myMacroCode10 As String = _
" If .Cells(rowNum_FirstData, mySortCol).Value
< .Cells(rowNum_LastData, mySortCol).Value 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 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 okToProceed = True
13013 End If
13019 End If

13020 If okToProceed = 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 )
13049 Set myCodeModule = myParentModule.CodeModule

13050 myMacroCode = myMacroCode01 & myMacroName &
myMacroCode02 & theRowNum_DataFirst & vbCrLf & myMacroCode03 &
theRowNum_DataLast & vbCrLf & myMacroCode04 &
theColNum_ButtonFirst & vbCrLf & myMacroCode05 &
theColNum_DataLast & vbCrLf & vbCrLf & myMacroCode06 &
myMacroName & myMacroCode07 & myMacroName & myMacroCode08 &
myMacroCode09 & myMacroCode10

13060 With myCodeModule
13061 .InsertLines .CountOfLines + 1, myMacroCode
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:=msoShapeIsoscelesTr iangle,
Top:=(.Top + .Height - myArrowHeight - 4), Height:=myArrowHeight,
Width:=myArrowWidth, Left:=(.Left + .Width - myArrowWidth - 2))
13086 Set curDownArrow =
..Parent.Shapes.AddShape(Type:=msoShapeIsoscelesTr iangle,
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, ""
Resume SortButtons_Create_xit
End Sub

Public Sub ExcelMacro_Add(ByVal theModuleName As String, ByVal
theMacroCode As String, ByRef theWB As excel.Workbook)
14000 debugStackPush mModuleName & ": ExcelMacro_Add"
14001 On Error GoTo ExcelMacro_Add_err

' PURPOSE: To create a new Sub in an Excel workbook AND a
code module component
' to contain it
' ACCEPTS: - Name of new module that will contain out routine
' - Tab-delimited text stream containing the code
for that Sub
' - Pointer to the workbook containing the existing
code module
'
' NOTES: 1) The macro's name is implicit in theMacroCode

14002 Dim myParentModule As VBComponent 'A component of
type CodeModule....
Dim myCodeModule As CodeModule

Dim newLine As Long 'We insert many lines under
this line#

' --------------------------------------------------------
' Create the code module that will contain our macro.
' What happens if there's alread a module with that name?
' Moot... because this routine is being used on a
newly-created
' spreadsheet

14010 Set myParentModule =
theWB.VBProject.VBComponents.Add(vbext_ct_StdModul e)
14019 myParentModule.Name = theModuleName & "_Module2"

14020 Set myCodeModule = myParentModule.CodeModule
14990 With myCodeModule
14991 newLine = .CountOfLines + 1
14992 .InsertLines newLine, theMacroCode
14999 End With

ExcelMacro_Add_xit:
DebugStackPop
On Error Resume Next
Set myCodeModule = Nothing
Set myParentModule = Nothing
Exit Sub

ExcelMacro_Add_err:
BugAlert True, ""
Resume ExcelMacro_Add_xit
End Sub
================================================== ==========
--
PeteCresswell

Here are some references:

http://education.mondadori.it/libri/...87-2_extra.pdf

http://www.mvps.org/dmcritchie/excel/getstarted.htm

http://computerprogramming.suite101....a_for_ms_excel

"Pierre Archambault" wrote:

Hi,

I want to create (via programmation) the declaration of some variables in
the declaration part of an existing module and also a new procedure in the
same module. Once done, I would like to run that procedure by clicking on a
button in an already open and running UserForm.

Thanks for your help.

Pierre

the usually cited reference:
http://www.cpearson.com/excel/vbe.htm

--
regards,
Tom Ogilvy


"Pierre Archambault" wrote:

Hi,

I want to create (via programmation) the declaration of some variables in
the declaration part of an existing module and also a new procedure in the
same module. Once done, I would like to run that procedure by clicking on a
button in an already open and running UserForm.

Thanks for your help.

Pierre