Free Microsoft Excel 2013
Quick Reference
Free Microsoft 2013 Quick Reference Guide

Free Microsoft Excel 2013 Quick Reference

[Solved] VBA : VBCodeMod As CodeModule

I'm tryng to delete Module3 procedure called DeleteAllVBA
I got this error message for VBCodeMod As CodeModule

"User- Defined type any suggestion not define"

Sub DeleteProcedure()

Dim VBCodeMod As CodeModule
Dim StartLine As Long
Dim HowManyLines As Long

Set VBCodeMod = ThisWorkbook.VBProject.VBComponents("Module3").CodeModule
With VBCodeMod
StartLine = .ProcStartLine("DeleteAllVBA", vbext_pk_Proc)
HowManyLines = .ProcCountLines("DeleteAllVBA", vbext_pk_Proc)
.DeleteLines StartLine, HowManyLines
End With

End Sub

??


Post your answer or comment

comments powered by Disqus
Hi.
I have a code which inserts some lines of code to new workbook..

Sub AddComboBoxCode2(VBCodeMod As CodeModule, sCodeName As String)
With VBCodeMod
.InsertLines .CountOfLines + 1, "Private Sub ComboBox1_Change()"
.InsertLines .CountOfLines + 1, " Dim TargetPivotTable As
PivotTable"
.InsertLines .CountOfLines + 1, " Dim units As String"
.InsertLines .CountOfLines + 1, " On Error GoTo ErrHandler"
.InsertLines .CountOfLines + 1, " Select Case ComboBox1.Value"

{...}

Everything works fine if VBA is open.
When I close VBA no code is added to workbook.

Did it happen to somebody?

I'd like to add a Procedure to a Worksheet Module via VBA.
The problem is that the module already contains a procedure,
so I need to learn how to add the procedure UNDER the existing procedure.
Attached is the procedure I'd like to add. Thanks in advance.

Sub addselectionchange()
Dim StartLine As Long
Dim VBCodeMod As CodeModule
Dim DEPT3 As String
Dim LINENUM As Integer

Set VBCodeMod =
ThisWorkbook.VBProject.VBComponents(Worksheets("All").CodeName).CodeModule

With VBCodeMod

StartLine = .CreateEventProc("SelectionChange", "Worksheet") + 1

.InsertLines StartLine, _
"lastAddress = Target.Address"

End With

End Sub

In worksheet called CAMOB I have the following code -

	VB:
	
 Range) 
     ''''''''''''''''''''''''''''''''''''''''''''
     'Forces text to Proper case for the range A15:A40
     ''''''''''''''''''''''''''''''''''''''''''''
    If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub 
     
    On Error Resume Next 
    If Not Intersect(Target, Range("A15:A40")) Is Nothing Then 
        Application.EnableEvents = False 
        Target = StrConv(Target, vbProperCase) 
        Application.EnableEvents = True 
    End If 
    On Error Goto 0 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
I have tried running this macro


	VB:
	
 DeleteProcedure() 
     
    Dim VBCodeMod As CodeModule 
    Dim StartLine As Long 
    Dim HowManyLines As Long 
     
    Set VBCodeMod = ThisWorkbook.VBProject.VBComponents("CAMOB").CodeModule 
    With VBCodeMod 
        StartLine = .ProcStartLine("MyNewProcedure", vbext_pk_Proc) 
        HowManyLines = .ProcCountLines("MyNewProcedure", vbext_pk_Proc) 
        .DeleteLines StartLine, HowManyLines 
    End With 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
To remove it but it won't run past the first line of code. I get a comile error: User definded type not defined.

Is this because the code is nnot in a module and if so how can I adapt the code to make it work?

Any help much appreciated.

Hi all -

Have a bit of code to list all procedures in project to a sheet.
Idea from Chip Pearson, adapted with help from Norie
Original thread
Reference is set to MS VBA Extensibility

Thought solved, but trying to use now only lists one procedure in the project
Namely the procedure in the module identified here :

	VB:
	
 VBCodeMod = ThisWorkbook.VBProject.VBComponents("mdl_comp_pl_ProcedureList").CodeModule 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
I tried many variations by stopping at

	VB:
	
 VBCodeMod = ThisWorkbook.VBProject 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
But receive error message
Objest doesn't support property Where did I go wrong?
Full code below.
Thanks
-markc


	VB:
	
 
 
Sub raw_pl_ProcedureList() 
     'Uses reference to Microsoft VBA extensibility
    Dim VBCodeMod As CodeModule 
    Dim StartLine As Long 
    Dim Msg As String 
    Dim ProcName As String 
    Dim wbBook As Workbook 
    Dim wsList As Worksheet 
    Dim rngProcedure As Range 
    Dim intCounter As Integer 
    intCounter = 1 
     
    With Application 
        .DisplayAlerts = False 
        .Calculation = xlCalculationManual 
        .ScreenUpdating = False 
    End With 
     
     'Change name of module
     '    Set VBCodeMod = ThisWorkbook.VBProject.VBComponents("mdl_comp_pl_ProcedureList").CodeModule
    Set VBCodeMod = ThisWorkbook.VBProject("raw_pl_strip.xls") 
     
    Set wbBook = ThisWorkbook 
     
     'Create a worksheet to list the procedures out to
    On Error Resume Next 
    ActiveWorkbook.Worksheets("ProcedureList").Delete 
    ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count) 
    ActiveSheet.Name = "ProcedureList" 
    Set wsList = wbBook.Worksheets("ProcedureList") 
     
    StartLine = VBCodeMod.CountOfDeclarationLines + 1 
    Do Until StartLine >= VBCodeMod.CountOfLines 
        wsList.Cells(intCounter, 1).Value = VBCodeMod.ProcOfLine(StartLine, vbext_pk_Proc) 
         
        StartLine = StartLine + _ 
        VBCodeMod.ProcCountLines(VBCodeMod.ProcOfLine(StartLine, _ 
        vbext_pk_Proc), vbext_pk_Proc) 
        intCounter = intCounter + 1 
         
    Loop 
     
    Set rngProcedure = Nothing 
    Set wsList = Nothing 
    Set wbBook = Nothing 
    Set VBCodeMod = Nothing 
     
     
    With Application 
        .DisplayAlerts = True 
        .Calculation = xlCalculationAutomatic 
        .ScreenUpdating = True 
    End With 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


vba save as dialog box...

i would like to create with vba the file save as dialog box...and then let the user name and save the file wherever they want to...

thank you...!

Hi all

Trying to list procedures in a module to a sht
Found a bit of code on Chip pearson's site to accomplish such.

I set the reference to Microsoft VBA Extensibility 5.3

I modified Chip's code slightly to list to sht instead of msgbox
All values returned are 0. Number of returns = 14 which is correct number
of procedures in the module.

Thanks
-marc


	VB:
	
 
 
Sub cv_ListProcedures() 
     
    Dim VBCodeMod As CodeModule 
    Dim StartLine As Long 
    Dim Msg As String 
    Dim ProcName As String 
    Dim wbBook As Workbook 
    Dim wsList As Worksheet 
    Dim rngProcedure As Range 
    Dim intCounter As Integer 
    intCounter = 16 
     
    Set wbBook = ThisWorkbook 
    Set wsList = wbBook.Worksheets("ListWorkSheets") 
     
     
    Set VBCodeMod = ThisWorkbook.VBProject.VBComponents("mdl_cv_SheetMgmt").CodeModule 
    With wsList 
        StartLine = VBCodeMod.CountOfDeclarationLines + 1 
        Do Until StartLine >= VBCodeMod.CountOfLines 
             '           Msg = Msg & .ProcOfLine(StartLine, vbext_pk_Proc) & Chr(13)
            StartLine = StartLine + _ 
            VBCodeMod.ProcCountLines(VBCodeMod.ProcOfLine(StartLine, _ 
            vbext_pk_Proc), vbext_pk_Proc) 
            .Cells(intCounter, 1).Value = vbext_pk_Proc 
            intCounter = intCounter + 1 
        Loop 
    End With 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Hello,

I am trying to display the result of a custom VBA function as a label on a userform. The function is called and takes arguments from three text boxes on the userform. I attached it to the exit parameter. (This may be part of the problem; I'm not sure).

There seem to be two problems, first all the text boxes don't always contain data, but because the arguments are not optional, I get a type mismatch error when the code runs (I tried switching some of them to optional, but it didn't help as you can see from my 'commented code).

The other problem is that even when all the arguments seem to be met (i.e. the text boxes all have data), I still get a compile error that the argument is not optional. This only happens if I try and pass the result to some aspect of the userform. As you can see from the last coded line in the custom function, if I assign it to a range on the worksheet, it functions fine.

Below are the codes. Any help you can provide would be appreciated. I use excel 03 and windows XP.

Note the exit procedure also contains a code that formats the text box to a specified date format, and this does work.

Code:
Private Sub txtStartDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim StartDate As Date
Dim EndDate As Date

    If IsDate(Me.txtStartDate.Value) Then
        StartDate = Me.txtStartDate.Value
        Me.txtStartDate.Value = Format(StartDate, "m/d/yyyy")
    Else:  MsgBox "Please enter a date"
    End If

Call CalcDate(txtStartDate, txtYears, txtMonths, txtDays)

EndDate = CalcDate

lblProjectPeriod.Caption = EndDate

End Sub
and the custom function:

Code:
Function CalcDate(StartDate As Date, Optional Years As Variant, Optional Months As Variant, _
    Optional Days As Variant) As Date
          
    'If IsMissing(Years) Then Years = False
       ' If Years = False Then Years = 0
       ' End If
    'End If
    'If IsMissing(Months) Then Months = False
       ' If Months = False Then Years = 0
     '   End If
   ' End If
   ' If IsMissing(Days) Then Days = False
       ' If Days = False Then Years = 0
       ' End If
    'End If
        
    CalcDate = DateAdd("yyyy", Years, StartDate)
    CalcDate = DateAdd("m", Months, CalcDate)
    CalcDate = DateAdd("d", Days, CalcDate)
    CalcDate = DateAdd("d", -1, CalcDate)
   
   'Range("L7") = CalcDate

Thanks for your help

I am using the the following code to list modeules and procedures. It is not listing "modules" alphabetically like that are listed in the VBE project????

Here is a sample of "module" names and how they are listed when I run the code>

Print1
Clock
HyperLinks
CB_Create
CB_HideShowDelete
OnAction
WS_GetNames


Dim MasterVBComp As VBComponents
Dim SingleVBComp As VBComponent
Dim VBCodeMod As CodeModule
Dim StartLine As Integer
Dim row As Long
Dim EndOfPageRow As Long
Dim col As Integer

Sheets("fil-Menu Maker-2").Select

'find the row for listing space
startRow = Range("A1:A100").Find("Macro Information").row + 1
row = startRow
EndOfPageRow = 70
col = 1

' Cells(startRow, 1).Resize(100, 6).Clear
' OR
With Range(Cells(startRow, 1), Cells(startRow + 100, 6))
.ClearContents
.Font.Bold = False
.IndentLevel = 0
End With

Set MasterVBComp = ThisWorkbook.VBProject.VBComponents
'module names first
For Each SingleVBComp In MasterVBComp
If SingleVBComp.Type = vbext_ct_StdModule Then
Cells(row, col) = SingleVBComp.Name
With Cells(row, col)
.Font.Bold = True
End With
row = row + 1
If row > EndOfPageRow Then
row = startRow
col = col + 2
End If

End If
'procedure names after its module name
If SingleVBComp.Type = vbext_ct_StdModule Then
Set VBCodeMod = SingleVBComp.CodeModule
StartLine = VBCodeMod.CountOfDeclarationLines + 1
Do Until StartLine >= VBCodeMod.CountOfLines
Cells(row, col) = VBCodeMod.ProcOfLine(StartLine, vbext_pk_Proc)
With Cells(row, col)
.IndentLevel = 1
End With
StartLine = StartLine + _
VBCodeMod.ProcCountLines(VBCodeMod.ProcOfLine(StartLine, _
vbext_pk_Proc), vbext_pk_Proc)

row = row + 1
If row > EndOfPageRow Then
row = startRow
col = col + 2
End If

Loop
End If
Next
End Sub


[ This Message was edited by: em on 2002-11-04 08:17 ]

[ This Message was edited by: em on 2003-02-01 00:03 ]

I would like to pass a VBA subroutine as an argument to another VBA
subroutine. If I pass the name of the variable subroutine as a string
and execute it using a Run statement in the host subroutine, the result
is significantly slower than if I put a Select/Case statement in the
host subroutine that directly calls the variable subroutine. E.g., if
ProcName1 is a string containing the name of procedure NamedProc1, then

Sub HOSTSUB(ProcName As String)
Run ProcName
End Sub

is slower than

Sub HOSTSUB(ProcName As String)
Select Case ProcName
Case ProcName1
NamedProc1
End Select
End Sub

Is there a better way to handle variable procedures in VBA?

Dave Ring

hello,

i have a file remove.xls in which i use such a code:

Sub DeleteAllCodeInModule()
Dim VBCodeMod As CodeModule
Dim StartLine As Long
Dim HowManyLines As Long

Set VBCodeMod = Workbooks("new.xls").VBProject.VBComponents("Sheet s4").CodeModule
With VBCodeMod
StartLine = 1
HowManyLines = .CountOfLines
.DeleteLines StartLine, HowManyLines
End With

End Sub

to remove Private Sub Worksheet_Calculate() in new.xls

than i save and close file, but on reopening new.xls an information about
existing macros is appears and i do not know why?
there is no VBA code in file. i checked carefully other sheets and ThisWorkbook
and they are empty...

does somebody has any idea what is going on? i use office xp..

regards
peter

Hello all,

I am new to programming and especially with Excel and VBA.

I hav a question.. Is it possible to use a VBA Macro as an Add-In. This program (Macro) will perform analyzes on data in one sheet and then export the result to another worksheet or new workbook itself.

Will it be possible this way to make the Excel files containing only data and all the Macros (program) not a part of it. When we will finish our analyzes the files can be circulated in our scientific community without any macros but containing only the input data and the analyzed output data. The output workbooks so obtained can also be uploaded to our database as we repeat the same procedure for lot of materials. So, we will have only excel sheets without any macros in it for circulation, discussion and in database.

Is it possible ?

thank you in advance for your kind help and please ignore my ignorance as I am a 'very' new user

regards
arora

Here are three code fragments. The first one works propely, the second two
cause Excel to crash. Can someone tell me what I am doing wrong? Thanks

The following code works properly:
Dim VBCodeMod As CodeModule
Dim LineNum As Long
Set VBCodeMod =
Workbooks(wb).VBProject.VBComponents("ThisWorkbook").CodeModule
With VBCodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, _
"Sub Workbook_Open()" & Chr(13) & _
"setLookupList" & Chr(13) & _
"End Sub"
End With

This code causes excel to crash:
Dim VBCodeMod As CodeModule
Dim LineNum As Long
Set VBCodeMod =
Workbooks(wb).VBProject.VBComponents("Sheet1").CodeModule
With VBCodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, _
"'Private Sub Worksheet_Change(ByVal Target As Range)" & Chr(13) & _
"'doIt Target" & Chr(13) & _
"End Sub"
End With

Similarly, this code also causes excel to crash:
Dim StartLine As Long
With Workbooks(wb).VBProject.VBComponents("Sheet1").CodeModule
StartLine = .CreateEventProc("Change", "Worksheet") + 1
.InsertLines StartLine, _
"dotIt Target"
End With

Hi,

I have a problem with crashing excel. I will include the code below but what it does is it add code to each sheet when the workbook first opens.
The problem occurs when adding code to the second sheet. I have pinpointed the problem to this line on its second pass through:
Set VBCodeMod = ThisWorkbook.VBProject.VBComponents(ThisWorkbook.Worksheets(i).CodeName).CodeModule
It will add the code for the first sheet but when it sets VBCodeMod for the second sheet it crashes

But if you copy and paste the code into excel you will see what happens.

Since it uses CodeModule make sure that you add in the References: Microsoft Visual Basic for Applications Extensibility 5.3

Private Sub Workbook_Open()

Dim ws As Worksheet, i As Integer
Dim VBCodeMod As CodeModule
Dim LineNum As Long
i = 0

For Each ws In ActiveWorkbook.Worksheets
i = i + 1
Set VBCodeMod = ThisWorkbook.VBProject.VBComponents(ThisWorkbook.Worksheets(i).CodeName).CodeModule
With VBCodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, _
"Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)" & Chr(13) & _
"'Some Code" & Chr(13) & _
"End Sub"
End With
Set VBCodeMod = Nothing
On Error GoTo 0
Next ws

Set ws = Nothing

End Sub

Goodluck!!

hello,

i have a file remove.xls in which i use such a code:

Sub DeleteAllCodeInModule()
Dim VBCodeMod As CodeModule
Dim StartLine As Long
Dim HowManyLines As Long

Set VBCodeMod = Workbooks("new.xls").VBProject.VBComponents("Sheets4").CodeModule
With VBCodeMod
StartLine = 1
HowManyLines = .CountOfLines
.DeleteLines StartLine, HowManyLines
End With

End Sub

to remove Private Sub Worksheet_Calculate() in new.xls

than i save and close file, but on reopening new.xls an information about
existing macros is appears and i do not know why?
there is no VBA code in file. i checked carefully other sheets and ThisWorkbook
and they are empty...

does somebody has any idea what is going on? i use office xp..

regards
peter

Hi,

I get a "subscript out of range error when I run this the first time after opening the spreadsheet. Anytime after this it works perfectly.

Dim VBCodeMod As CodeModule
.......
ThisWorkbook.Worksheets(newWorkSheetName).Activate

Set VBCodeMod = ThisWorkbook.VBProject.VBComponents (ActiveSheet.CodeName).CodeModule

The problem is that ActiveSheet.CodeName comes up blank instead of being something like "Sheet1" etc
Any ideas on hope to stop ActiveSheet.CodeName from being blank when I run the code for the first time after opening the spreadsheet

Thanks

There is a beautiful code

Private Sub ComboBox1_Change()
Dim TargetPivotTable As PivotTable
On Error GoTo ErrHandler
Set TargetPivotTable = ActiveSheet.PivotTables("pivottable1")
Worksheet_PivotTableUpdate TargetPivotTable
ErrHandler:
End Sub

This code pasted into worksheet module works fine

The same code inserted from VBA crashes during insertion at first
..insertLines.

Dim VBCodeMod As CodeModule
Set VBCodeMod = wkb.VBProject.VBComponents(sModuleName).CodeModule
With VBCodeMod
.InsertLines .CountOfLines + 1, "Private Sub ComboBox1_Change()"
.InsertLines .CountOfLines + 1, " Dim TargetPivotTable As
PivotTable"
.InsertLines .CountOfLines + 1, " On Error GoTo ErrHandler"
.InsertLines .CountOfLines + 1, " Set TargetPivotTable =
ActiveSheet.PivotTables(""pivottable1"")"
.InsertLines .CountOfLines + 1, " Worksheet_PivotTableUpdate
TargetPivotTable"
.InsertLines .CountOfLines + 1, "ErrHandler:"
.InsertLines .CountOfLines + 1, "End Sub"

I noticed that:
inserting non-events procedures works.
Using CreateEventProc also crashes
inserting to ThisWorkbook module work, but inserting into specific
sheet doesn't

What am I doing wrong?

Hello All,

I'm new here and hope someone can help me, I've searched the board and cannot find a solution to this problem.

I’m launching a new workbook, exporting some stuff, basically creating a report. But then I want to add a BeforePrint event to the new worksheet. Both of the macro below works great right up until I change “Sheet1” to “ThisWorkBook”…then Excel crashes.

Any Suggestions?


	VB:
	
 AddCode1() 
    Dim VBCodeMod As CodeModule 
    Dim LineNum As Long 
    Dim Copybook As Workbook 
     
    Set Copybook = Excel.Workbooks.Add 
    Set VBCodeMod = Copybook.VBProject.VBComponents("sheet1").CodeModule 
     
    LineNum = VBCodeMod.CountOfLines + 1 
    VBCodeMod.InsertLines LineNum, "Private Sub Workbook_BeforePrint(Cancel As Boolean)" & Chr(13) & "if ActiveSheet.CodeName
 ""Sheet1"" or  ActiveSheet.CodeName  ""Sheet2"" or ActiveSheet.CodeName  ""Sheet3"" then" & Chr(13) & "MsgBox(""This
Electronic Outcome Review Summary Report is NOT optimized for Printing.  Printing this tab will yield less than optimal
results."")" & Chr(13) & "End If" & Chr(13) & "End Sub" 
     
End Sub 
 
 
Sub addCode2() 
    Dim LineNum As Long 
    Dim Copybook As Workbook 
    Set Copybook = Excel.Workbooks.Add 
    With ActiveWorkbook.VBProject.VBComponents("Sheet1").CodeModule 
        LineNum = .CreateEventProc("BeforePrint", "Workbook") + 1 
        .InsertLines StartLine, "Private Sub Workbook_BeforePrint(Cancel As Boolean)" & Chr(13) & "if ActiveSheet.CodeName 
""Sheet1"" or  ActiveSheet.CodeName  ""Sheet2"" or ActiveSheet.CodeName  ""Sheet3"" then" & Chr(13) & "MsgBox(""This
Electronic Outcome Review Summary Report is NOT optimized for Printing.  Printing this tab will yield less than optimal
results."")" & Chr(13) & "End If" & Chr(13) & "End Sub" 
    End With 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


I use code as below to create ComboBox and its change event, it is ok if one control and handler is created one time, you can try to run Test1(), then Test2(). But if two or above are created in the same time, try Test(), a windows fault dialog will be popuped.

I don't know what ahppened, can you help me? Thank you very much.

	VB:
	
 Test1() 
    Call AddCtrl(Cells(9, 10), Array(321, 231, 123)) 
End Sub 
 
Sub Test2() 
    Call AddCtrl(Cells(9, 11), Array(321, 231, 123)) 
End Sub 
 
Sub Test() 
    Call AddCtrl(Cells(9, 10), Array(321, 231, 123)) 
    Call AddCtrl(Cells(9, 11), Array(321, 231, 123)) 
End Sub 
 
Sub AddCtrl( _ 
    ByVal vCell As Range, _ 
    ByVal vItems As Variant, _ 
    Optional ByVal vIndex As Integer = 1 _ 
) 
    Dim iLeft As Integer, iTop As Integer, iWidth As Integer, iHeight As Integer 
    Dim oCombo As OLEObject, vItem As Variant, sName As String 
     
    Call DeleteCtrl(vCell) 
     
    sName = Chr(64 + vCell.Column) & vCell.Row 
     
    vCell.Select 
    iLeft = ActiveCell.Left 
    iTop = ActiveCell.Top 
    iWidth = ActiveCell.Width 
    iHeight = ActiveCell.Height 
     
    On Error Resume Next 
    Set oCombo = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1") 
     
    With oCombo 
        With .Object 
            For Each vItem In vItems 
                .AddItem vItem 
            Next 
             
            .Font.Size = 9 
            .ListIndex = vIndex 
        End With 
         
        .Name = sName 
        .Left = iLeft 
        .Top = iTop 
        .Width = iWidth + 2 
        .Height = iHeight 
        .LinkedCell = vCell.Address 
    End With 
    On Error Goto 0 
     
    Call AddProc(vCell) 
     'Cells(vCell.Row, 2).Select
End Sub 
 
Sub DeleteCtrl(ByVal vCell As Range) 
    Dim oCombo As OLEObject 
     
    On Error Resume Next 
    Set oCombo = ActiveSheet.OLEObjects(Chr(64 + vCell.Column) & vCell.Row) 
     
    If Not oCombo Is Nothing Then 
        oCombo.Delete 
         
        Call DeleteProc(vCell) 
    End If 
    On Error Goto 0 
End Sub 
 
Sub AddProc( _ 
    ByVal vCell As Range _ 
) 
    Dim VBCodeMod As CodeModule, StartLine As Long, Proc As String 
    Dim TABS As String, LF As String, AP As String 'Apostrophe
    Dim sSheet As String, sName As String 
     
    AP = Chr(34) 
    TABS = Chr(9) 
    LF = Chr(13) 
     
    Call DeleteProc(vCell) 
     
    sSheet = ActiveSheet.CodeName 
    sName = Chr(64 + vCell.Column) & vCell.Row 
     
    Proc = TABS & "Cells(" & vCell.Row & ", " & vCell.Column & ") = " & sName & ".Value" 
     
    On Error Resume Next 
    Set VBCodeMod = ActiveWorkbook.VBProject.VBComponents(sSheet).CodeModule 
     
    With VBCodeMod 
        StartLine = .CreateEventProc("Change", sName) + 1 
        .InsertLines StartLine, Proc 
    End With 
     
    Set VBCodeMod = Nothing 
    On Error Goto 0 
End Sub 
 
Sub DeleteProc( _ 
    ByVal vCell As Range _ 
) 
    Dim VBCodeMod As CodeModule, StartLine As Long, HowManyLines As Long 
    Dim sName As String, sSheet As String 
     
    sSheet = ActiveSheet.CodeName 
    sName = Chr(64 + vCell.Column) & vCell.Row & "_Change" 
     
    On Error Resume Next 
    Set VBCodeMod = ThisWorkbook.VBProject.VBComponents(sSheet).CodeModule 
     
    With VBCodeMod 
        StartLine = .ProcStartLine(sName, vbext_pk_Proc) 
        HowManyLines = .ProcCountLines(sName, vbext_pk_Proc) 
        .DeleteLines StartLine, HowManyLines 
    End With 
    Set VBCodeMod = Nothing 
    On Error Goto 0 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


hi guys,

i'm trying to tweak Chip's code (http://www.cpearson.com/excel/vbe.htm) to include the body of the module as well.
it works, but when there's blank lines in-between modules it'd show less of the modules.

is there a way to delete the empty line in VBE?
or did i miss something out in the code below?

thanks for any advice in advance


	VB:
	
 ListProcedures() 
     
    Dim VBCodeMod As CodeModule 
    Dim StartLine As Long 
    Dim Msg As String 
    Dim ProcName As String 
     
    Set VBCodeMod = ThisWorkbook.VBProject.VBComponents("MyModule").CodeModule 
    With VBCodeMod 
         
        StartLine = .CountOfDeclarationLines + 1 
        Do Until StartLine >= .CountOfLines 
            Msg = Msg & Chr(13) & .Lines(StartLine, vbext_pk_Get) & Chr(13) 
            StartLine = StartLine + _ 
            .ProcCountLines(.ProcOfLine(StartLine, _ 
            vbext_pk_Get), vbext_pk_Proc) 
        Loop 
         
    End With 
     
    Msgbox Msg 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


I've seen multi-tiered classes used in other languages as the main form of interaction with a db. The idea is that it if you create a class for each table you can use one line methods to do what we now write whole subs for. The problem for us, as I see it, is that these classes would take a long time to write so only people writing big applications can do it. However theoretically all the info to write the classes is in the database so you should be able to get the classes to write themselves.

Last night I finally made a start with the code below. At the moment I have only included one method (Dump data to spreadsheet). On my machine it is "working" in that it creates a very simple class for each table to any database you connect to.

If anybody wants to try it you need to add the required references and then change the path of the Access database in the GetDbFullPath function then run WriteAllClasses.

In needs some thinking about so I am looking for suggestions/ideas to bounce around and see where to take this eg. what methods and properties to include.


	VB:
	
 '
 ' Class Writer Module for MS Access - Requires :-
 ' Reference to Microsoft ActiveX Object 2.x
 ' Reference to Microsoft VB extensibility
 ' Trust access to VB project checked in macro security
 '
Private Function GetDbFullPath() 
    GetDbFullPath = "c:EDIEDI.mdb" ' #### CHANGE DB PATH  AND RUN WriteAllClasses ####
End Function 
 
Public Sub WriteAllClasses() 
     
    Dim Cn As ADODB.Connection 
    Dim RsTables As ADODB.Recordset 
    Dim RsFields As ADODB.Recordset 
     
    Call CnAccess(Cn) 
    Set RsTables = GetTables(Cn) 
    RsTables.MoveFirst 
    Do While Not RsTables.EOF 
        Set RsFields = GetTableFields(Cn, RsTables(2)) 
        Call WriteClass(RsTables(2), RsFields) 
        RsTables.MoveNext 
    Loop 
    Call WriteClassRefs(RsTables) 
    Call WriteTestMod(RsTables) 
End Sub 
 
Public Sub CnAccess(ByRef Cn As ADODB.Connection) 
     
    Dim UserId As String 
    Dim Password As String 
     
    UserId = "" 
    Password = "" 
    Set Cn = New ADODB.Connection 
    Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & GetDbFullPath & ";", UserId, Password 
     
End Sub 
 
Private Sub WriteClass(TableName As String, RsFields As ADODB.Recordset) 
     
    Dim VBComp As VBComponent 
    Dim VBCodeMod As CodeModule 
    Dim LineNum As Long 
    Dim FieldString As String 
     
    FieldString = "Private Cn as ADODB.Connection" & Chr(13) & "Private Rs as ADODB.Recordset" & Chr(13) 
     
    If ModExists("c" & TableName) Then ModDelete ("c" & TableName) 
    Set VBComp = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_ClassModule) 
    VBComp.Name = "c" & TableName 
    Set VBCodeMod = VBComp.CodeModule 
     
    RsFields.MoveFirst 
     '
    Do While Not RsFields.EOF 
        FieldString = FieldString & "Private F" & Trim(RsFields.Fields(3)) & " " & GetFieldType(RsFields.Fields(11)) &
Chr(13) 
        RsFields.MoveNext 
    Loop 
    FieldString = FieldString & DumpToSheetMethod(TableName) 
     
    LineNum = VBCodeMod.CountOfLines + 1 
    VBCodeMod.InsertLines LineNum, FieldString 
     
End Sub 
 
Private Function GetTables(Cn As ADODB.Connection) As ADODB.Recordset 
    Set GetTables = New ADODB.Recordset 
    Set GetTables = Cn.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "Table")) 
End Function 
 
Private Function GetTableFields(Cn As ADODB.Connection, TableName As String) As ADODB.Recordset 
    Set GetTableFields = New ADODB.Recordset 
    Set GetTableFields = Cn.OpenSchema(adSchemaColumns, Array(Empty, Empty, TableName)) 
End Function 
 
Private Function ModExists(ModName As String) As Boolean 
    On Error Resume Next 
    ModExists = Len(ThisWorkbook.VBProject.VBComponents(ModName).Name)  0 
End Function 
 
Private Sub ModDelete(ModName As String) 
    Dim VBComp As VBComponent 
    Set VBComp = ThisWorkbook.VBProject.VBComponents(ModName) 
    ThisWorkbook.VBProject.VBComponents.Remove VBComp 
    Set VBComp = Nothing 
End Sub 
 
Private Function GetFieldType(FieldType As Integer) As String 
    Select Case FieldType 
    Case 130 
        GetFieldType = "as String" 
    Case 3 
        GetFieldType = "as Integer" 
    Case 5 
        GetFieldType = "as Double" 
    Case 11 
        GetFieldType = "as Boolean" 
    Case 7 
        GetFieldType = "as Date" 
    End Select 
End Function 
 
Private Sub RemoveClasses() 
     '                                       Removes all classes from this workbook
    Dim VBComp As VBComponent 
    Dim VBCodeMod As CodeModule 
     
    For Each VBComp In ThisWorkbook.VBProject.VBComponents 
        If VBComp.Type = vbext_ct_ClassModule Then 
            ThisWorkbook.VBProject.VBComponents.Remove VBComp 
        End If 
    Next VBComp 
End Sub 
 
Private Sub WriteClassRefs(RsTables As ADODB.Recordset) 
     '              Overwrites the ClassRefs standard module which dimensions an instance of each class
    Dim VBComp As VBComponent 
    Dim VBCodeMod As CodeModule 
    Dim LineNum As Long 
    Dim FieldString As String 
     
    FieldString = "' This sub references all the Access classes" & Chr(13) 
     
    If ModExists("ClassRefs") Then ModDelete ("ClassRefs") 
    Set VBComp = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule) 
    VBComp.Name = "ClassRefs" 
    Set VBCodeMod = VBComp.CodeModule 
     
    RsTables.MoveFirst 
    Do While Not RsTables.EOF 
        FieldString = FieldString & "Public Obj" & RsTables.Fields(2) & " As New c" & RsTables.Fields(2) & " " & Chr(13) 
        RsTables.MoveNext 
    Loop 
     
    LineNum = VBCodeMod.CountOfLines + 1 
    VBCodeMod.InsertLines LineNum, FieldString 
     
End Sub 
 
Private Function DumpToSheetMethod(TableName As String) As String 
    DumpToSheetMethod = "Public Sub DumpToSheet(DumpRange As Range)" & Chr(13) & _ 
    "Call CnAccess(Cn)" & Chr(13) & _ 
    "Set Rs = New ADODB.Recordset" & Chr(13) & _ 
    "Rs.Open " & Chr(34) & TableName & Chr(34) & ",Cn" & Chr(13) & _ 
    "DumpRange.CopyFromRecordset Rs" & Chr(13) & _ 
    "Rs.Close" & Chr(13) & _ 
    "Set Rs = Nothing" & Chr(13) & _ 
    "End Sub" & Chr(13) 
End Function 
 
Private Sub WriteTestMod(RsTables As ADODB.Recordset) 
     '              Overwrites the Test standard module with a sub for each table testing the dump method
    Dim VBComp As VBComponent 
    Dim VBCodeMod As CodeModule 
    Dim LineNum As Long 
    Dim FieldString As String 
     
    FieldString = "' Test sub for DumpToSheet method " & Chr(13) & Chr(13) 
     
    If ModExists("Test") Then ModDelete ("Test") 
    Set VBComp = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule) 
    VBComp.Name = "Test" 
    Set VBCodeMod = VBComp.CodeModule 
     
    RsTables.MoveFirst 
    Do While Not RsTables.EOF 
        FieldString = FieldString & "Sub TEST" & RsTables.Fields(2) & "()" & Chr(13) & _ 
        "Obj" & RsTables.Fields(2) & ".DumpToSheet(Worksheets(1).range(" & Chr(34) & "a1" & Chr(34) & "))" & Chr(13) & _ 
        "End sub" & Chr(13) 
        RsTables.MoveNext 
    Loop 
     
    LineNum = VBCodeMod.CountOfLines + 1 
    VBCodeMod.InsertLines LineNum, FieldString 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Cheers,

Carl

Hi everybody,

I added a CommandButton on a sheet using a function and after that I have written the coresponding code for "click" action.
After the program runs, it appears Visual Basic Editor and show the code for CommandButton_click. I would like that after running of program to remain on Excel Sheet. What can I do?

The code I have written for adding the comandButton is:


	VB:
	
    Dim vbCodeMod As CodeModule 
    Dim oleButton As OLEObject 
     
    Dim lngLines As Long 
    Dim wbUpdate As Workbook 
    Set wbUpdate = Application.ActiveWorkbook 
    Dim shtControls As Worksheet 
    Set shtControls = Application.ActiveWorkbook.ActiveSheet 
     
     
     'Turn screen off
    Application.ScreenUpdating = False 
     
     'Add the button to the sheet
    Set oleButton = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False _ 
    , DisplayAsIcon:=False, Left:=300.5, Top:=12.5, Width:=169.5, Height _ 
    :=34.5) 
     'Rename the button, so that the code added later refers to it
    oleButton.name = "Prepare" 
    oleButton.Object.Caption = "Click to prepare for Sending" 
     'Add code to trigger action
     
    With wbUpdate.VBProject.VBComponents(shtControls.CodeName).CodeModule 
         'Add event procedure for prepare_click
        lngLines = .CreateEventProc("click", "prepare") + 1 
         'Now add the code
        .InsertLines lngLines, "Call PrepareMacro" 
    End With 
     
     
     'Turn screen back on
    Application.ScreenUpdating = True 
     
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
I am waiting for a solution. Thanks a lot!
All the best !

Hi,

I have a macro which does some data manipulation, and as such moves between worksheets. For one of the sheets (CustomSheet)I want to have a message box each time the sheet (CustomSheet)is selected, which I have got written by an updating macro. However this macro moves between sheets, and each time the code goes to the CustomSheet it pops up this window.

I tried putting the "Application.DisplayAlerts = False" in, but I still get the messagebox.

I then tried to get the macro to delete the code when it starts to run (as each time it runs it has to change the Worksheet_Activate procedure for the CustomSheet) but for some reason it does not delete the code. My code to delete the Worksheet_Activate is as follows:


	VB:
	
 CodeModule 
Dim StartLine As Long 
Dim HowManyLines As Long 
 
On Error Resume Next 
Set VBCodeMod = ThisWorkbook.VBProject.VBComponents("Customsht").CodeModule 
With VBCodeMod 
    StartLine = .ProcStartLine("Worksheet_Activate", vbext_pk_Proc) 
    HowManyLines = .ProcCountLines("Worksheet_Activate", vbext_pk_Proc) 
    .DeleteLines StartLine, HowManyLines 
End With 
On Error Goto 0 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
which i found (and edited slightly) from http://www.cpearson.com/excel/vbe.htm

The code for the WorkSheet_Activate event is:


	VB:
	
 Worksheet_Activate() 
    On Error Resume Next 
    MsgBox " The Custom Sheet contains the ""Style"" information for ""Colin"".", vbOKOnly, "Custom Sheet Selected" 
    Exit Sub 
    On Error Goto 0 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Which will always be the same appart from 'Style' and 'Colin'

Hope someone can help,

best regards,

Robert

Hi everybody,

I would like to add a CommandButton to a Sheet and to insert the corresponding code for "click". I found some helping code on this forum, I have adapted to my case, but I get an error. Maybe somebody can help me.

The solution that I found was: "adding a button and code to an existing spreadsheet I had issued. Rather than trying to add the entire code under the button, I export a module containing the procedure "PrepareMacro" and then import it back into the workbook being updated."


	VB:
	
 addButtonOnPage() 
    Dim vbCodeMod As CodeModule 
    Dim oleButton As OLEObject 
     
    Dim lngLines As Long 
    Dim bolSkip As Boolean 
    Dim strPath As String 
    Dim wbUpdate As Workbook 
    Set wbUpdate = Application.ActiveWorkbook 
    Dim shtControls As Worksheet 
    Set shtControls = Application.ActiveWorkbook.ActiveSheet 
     
     'Turn screen off
    Application.ScreenUpdating = False 
     
     'Add the button to the sheet
    Set oleButton = ActiveSheet.OLEObjects.Add 
    (ClassType:="Forms.CommandButton.1", Link:=False _ 
    , DisplayAsIcon:=False, Left:=300.5, Top:=12.5, Width:=169.5, Height _ 
    :=34.5) 
     'Rename the button, so that the code added later refers to it
    oleButton.name = "Prepare" 
    oleButton.Object.Caption = "Click to prepare for Sending" 
     'Add code to trigger action
     
    With wbUpdate.VBProject.VBComponents(shtControls.CodeName).CodeModule 
         'Add event procedure for prepare_click
        lngLines = .CreateEventProc("click", "prepare") + 1 
         'Now add the code
        .InsertLines lngLines, _ 
        "PrepareMacro" 
    End With 
     
     
     'Copy the code module to the selected workbbok
    With ThisWorkbook 
         'Name for temp file to store code
        strPath = .Path & "code.txt" 
         'Export code to temp file
        .VBProject.VBComponents("Update1").Export strPath 
    End With 
     'Import code from temp file
    ActiveSheet.VBProject.VBComponents.Import strPath 
     'Delete the temp file
    Kill strPath 
     
     'Turn screen back on
    Application.ScreenUpdating = True 
     
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Running step by step I get to the line With wbUpdate.VBProject.VBComponents(shtControls.CodeName).CodeModule the following error:
Programmatic acces to Visual Basic Project is not trusted

What can I do ?

This solution I have found on forum under:
http://www.ozgrid.com/forum/showthre...+commandbutton .
In that case he open the file, in my case the file is open and the desired sheet is already activate.

Thanks a lot !
All the best!

hi,
i have coded the following lines, but i am not sure of how to insert
code within the macro Button_click. Also I am not sure of what
"Module1" is.
can someone help me please?
TIA!
Tina
================================================== ==========
For i = 0 To 4
ActiveSheet.Buttons.Add(50 + i * 100, 10, 80, 25).Select
Selection.OnAction = "Button_click"
Selection.Characters.Text = "Play Game" & i

Dim VBCodeMod As CodeModule
Dim LineNum As Long

Set VBCodeMod =
ThisWorkbook.VBProject.VBComponents_("Module1").Co deModule

With VBCodeMod
LineNum = .CountOfLines + 1

*** what do i write here to display a messagebox?
*** i want to add code to the Button_click macro.

End With
ActiveSheet.Range("A1").Select
Next i


No luck finding an answer? You could always try Google.