I am using the following to add a sub routine to a module:
Public Sub AddInfoProcedure(SubName As String)
Dim VBP As VBProject
Dim VBC As VBComponent
Dim CodeMod As CodeModule
Set VBP = Application.VBE.ActiveVBProject
Set VBC = VBP.VBComponents("Reference_Info_Options")
Set CodeMod = VBC.CodeModule
Stop
With CodeMod
XNum1 = .CountOfLines + 2
.InsertLines XNum1, "Sub " & SubName & "()" & Chr(13) & Chr(10) & "End Sub"
End With
Stop
End Sub
It runs with no problem in that it does add the sub however at the .insertlines line it breaks and gives the error as below:
'Can't Enter break mode at this time' Continue, end etc
Can anyone tell me why it is doing this? or how I can stop the error?
Related
Im trying to use the replaceline function to update code in Access VBA module. it keeps coming up with a compile error. Ive checked that the VBA Extension are selected and compared it to other examples that I have looked up.
this is the first time that Ive used this type of function, so I haven't fully got my head around them.
code below
Sub ReplaceCodeModuleText(strModule As String, strFindWhat As String, strReplaceWith As String)
'FUNCTION:
' Search the code module for specific text
' Replace with new text
Dim VBProj As VBProject
Dim VBComp As VBComponent
Dim CodeMod As CodeModule
Dim SL As Long ' start line
Dim EL As Long ' end line
Dim SC As Long ' start column
Dim EC As Long ' end column
Dim strCodeLine As String
Dim vDummy As Variant
Dim Found As Boolean
Set VBProj = Application.VBE.ActiveVBProject
Set VBComp = VBProj.VBComponents(strModule)
Set CodeMod = VBComp.CodeModule ' '.CodeModule
With CodeMod
SL = 1: EL = .CountOfLines
SC = 1: EC = 255
Found = .Find(Target:=strFindWhat, StartLine:=SL, StartColumn:=SC, _
EndLine:=EL, EndColumn:=EC, _
wholeword:=True, MatchCase:=False, patternsearch:=False)
If Found Then
strCodeLine = CodeMod.Lines(SL, 1)
strCodeLine = Replace(strCodeLine, strFindWhat, strReplaceWith, Compare:=vbTextCompare) 'not case sensitive = vbTextCompare
.ReplaceLine(SL, strCodeLine)
Debug.Print "Successfully Replaced: " & strFindWhat & " in VBA Module: " & strModule & " with : " & strReplaceWith
Else
Debug.Print "Did not find: " & strFindWhat;
End If
End With
End Sub
.ReplaceLine(SL, strCodeLine)
must be either
Call .ReplaceLine(SL, strCodeLine)
or
.ReplaceLine SL, strCodeLine
I have a listbox control that is suppose to populate a list of the items selected into a MsgBox, but I keep getting an error code when I run it.
ERROR: Compile error: Method or data member not found
What am I doing wrong?
Private Sub ctrSend_Click()
Dim msg As String
Dim i As Integer
Dim lstMsg As ListBox
If lstShipping.ListIndex = -1 Then
msg = "Nothing"
Else
msg = ""
For i = 0 To lstShipping.ListCount - 1
If lstShipping.Selected(i) Then _
msg = msg & lstMsg.List(i) & vbCrLf
Next i
End If
MsgBox "You selected: " & vbCrLf & msg, vbOKOnly, "Selected BIN"
Unload Me
End Sub
You are looping on lstShipping, yet looking at items from lstMsg. Is that really what you want to do? If not, change lstMsg to lstShipping as below:
Private Sub ctrSend_Click()
Dim msg As String
Dim i As Integer
Dim oItem as Variant
' Dim lstMsg As ListBox
If lstShipping.ListIndex = -1 Then
msg = "Nothing"
Else
msg = ""
For Each oItem in lstShipping.ItemsSelected
msg = msg & lstShipping.ItemData(oItem) & vbCrLf ' <--- lstShipping!
Next
End If
MsgBox "You selected: " & vbCrLf & msg, vbOKOnly, "Selected BIN"
DoCmd.Close
End Sub
Having a very weird problem. I have a function which is called when a form field gets focus. The function is passed four arguments, three of which are values from form fields and the fourth is a global variable which is set when the form loads. The function uses these variables to calculate the value for the field which called the function. This function is called in two different places. Everything was working fine, and now suddenly the function works when called from one place and doesn't work from the other, generating a 2467 run-time error, 'The expression you entered refers to an object that is closed or doesn't exists'. I've checked that the values of the arguments being passed are correct, the function exists OK, so can't see why I'm getting this error. Anyone any ideas?
Private Sub cboFinalStage_GotFocus()
'lookup stage based on TNM values
cboFinalStage = FindStage(cboFinalStageT, cboFinalStageN, cboFinalStageM, gblCancer)
End Sub
Public Function FindStage(cboT As ComboBox, cboN As ComboBox, cboM As ComboBox,
strCancer As String) As String
'use the TNM values entered to find the correct stage for the site and return it
'error handling
If gcfHandleErrors Then On Error GoTo PROC_ERR
'declare variables
Dim strTemp As String
Dim strTable As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strQuery As String
Dim strSite As String
Dim strSiteFull As String
Dim strT As String
Dim strN As String
Dim strM As String
'initialise variables - if there are no values entered in the 3 comboboxes, exit
'load tumour first in case it isn't already loaded
Forms!frmContainer.subTumour.SourceObject = "fsubTumour"
If Not IsNull(Forms!frmContainer.subTumour.Form!txtICD10) Then
strSite = Left(Forms!frmContainer.subTumour.Form!txtICD10, 3)
strSiteFull = Forms!frmContainer.subTumour.Form!txtICD10
End If
If Not IsNull(cboT.Value) Then
strT = cboT.Value
Debug.Print "T is " & strT
End If
If Not IsNull(cboN.Value) Then
strN = cboN.Value
Debug.Print "N is " & strN
End If
If Not IsNull(cboM.Value) Then
strM = cboM.Value
Debug.Print "M is " & strM
End If
If (IsNull(strT) Or IsNull(strN) Or IsNull(strM)) Then
Debug.Print "null so exiting"
Exit Function
End If
'identify the correct AJCC lookup table by cancer site
Select Case [strCancer]
Case "bla"
strTable = "lkp_AJCC_bladder"
Case "bre"
strTable = "lkp_AJCC_breast"
...
End Select
Debug.Print "AJCC table is " & strTable
'query the AJCC lookup table for the stage
strQuery = "SELECT c_stage FROM " & strTable & " WHERE (((t_value)='" & strT & "')
AND ((n_value)='" & strN & "') AND ((m_value)='" & strM & "'))"
Debug.Print "query is " & strQuery
Set db = CurrentDb
Set rs = db.OpenRecordset(strQuery)
If Not rs.EOF Then
strTemp = rs.Fields(0).Value
Debug.Print "result is " & strTemp
End If
rs.Close
db.Close
'return stage
FindStage = strTemp
'error handling
PROC_EXIT:
Exit Function
PROC_ERR:
If (Err.Number = 2467) Then
MsgBox "Unable to evaluate the stage", vbOKOnly, "Processing error"
Resume PROC_EXIT
Else
MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
Resume PROC_EXIT
End If
End Function
I have an access report that updates 4 image controls based on a table that is sourcing images from a directory. The report generates a page per record, however the image controls are not changing after page 1 (just showing same images for all the other pages). Appartently, the code worked fine on Windows XP and now does not work on Windows 7 OS (both used Office 07). Here is the code:
Private Sub Report_Current()
UpdateImages
End Sub
Private Sub Report_Load()
UpdateImages
End Sub
Private Sub Report_Page()
UpdateImages
End Sub
Private Sub UpdateImages()
On Error GoTo errHandler
Dim RS As DAO.Recordset
Set RS = CurrentDb.OpenRecordset("SELECT Image_Loc, Image_Name FROM HH_Media WHERE InspectionID = " & CInt(Me.InspectionID.Value) & " ORDER BY MediaID ASC")
If Not RS.BOF And Not RS.EOF Then
Dim i As Integer
For i = 1 To 4
If Not RS.EOF Then
Dim pictureCtrl As Image
Set pictureCtrl = GetControl("Image" & i)
Dim strImage As String
strImage = RS.Fields("Image_Loc").Value & "\" & RS.Fields("Image_Name").Value
If Not pictureCtrl Is Nothing Then
If FileExists(strImage) Then
pictureCtrl.Picture = strImage
SetLabel "lblImage" & i, RS.Fields("Image_Name").Value
Else
pictureCtrl.Picture = ""
SetLabel "lblImage" & i, "Does not exist"
End If
End If
RS.MoveNext
Else
Exit For
End If
Next
End If
RS.Close
Set RS = Nothing
Exit Sub
errHandler:
MsgBox "An error occurred while updating the form display." & vbNewLine & Err.Description, vbApplicationModal + vbCritical + vbDefaultButton1 + vbOKOnly, Me.Name
Resume Next
End Sub
The images do exist in the directory that are referenced in the table. Any ideas of what is missing?
Thank You
Whenever I need to do some dynamic content I always use the [section]_Format event - so if your controls are on the Detail section then:
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
If FormatCount = 1 then 'only need to do this once per record
UpdateImages
Endif
End Sub
I've never seen the GetControl method, and I don't have a lot of experience using the Image control, but it seems like that the Dim statement should read more like:
Dim pictureCtrl as Control
Set pictureCtrl = Me.Controls("Image" & i)
I would insert a break and verify that
strImage = RS.Fields("Image_Loc").Value & "\" & RS.Fields("Image_Name").Value
is returning values you expect. You can also shorten these to:
strImage = rs!Image_Loc & "\" & rs!Image_Name
sometimes Access doesn't like the added ".value" as this is already the default return.
I'm executing a query like this
select field from table;
In that query, there is a loop running on many tables. So, if the field is not present in a table I get a
Runtime Error 3061
How can I by pass this error such as that on this error flow should go to another point?
This is the code I have recently after going through this forum.
Option Explicit
Private Sub UpdateNulls()
Dim rs2 As DAO.Recordset
Dim tdf As DAO.TableDef
Dim db As Database
Dim varii As Variant, strField As String
Dim strsql As String, strsql2 As String, strsql3 As String
Dim astrFields As Variant
Dim intIx As Integer
Dim field As Variant
Dim astrvalidcodes As Variant
Dim found As Boolean
Dim v As Variant
Open "C:\Documents and Settings\Desktop\testfile.txt" For Input As #1
varii = ""
Do While Not EOF(1)
Line Input #1, strField
varii = varii & "," & strField
Loop
Close #1
astrFields = Split(varii, ",") 'Element 0 empty
For intIx = 1 To UBound(astrFields)
'Function ListFieldDescriptions()
Dim cn As New ADODB.Connection, cn2 As New ADODB.Connection
Dim rs As ADODB.Recordset, rs3 As ADODB.Recordset
Dim connString As String
Dim SelectFieldName
Set cn = CurrentProject.Connection
SelectFieldName = astrFields(intIx)
Set rs = cn.OpenSchema(adSchemaColumns, Array(Empty, Empty, Empty, SelectFieldName))
'Show the tables that have been selected '
While Not rs.EOF
'Exclude MS system tables '
If Left(rs!Table_Name, 4) <> "MSys" Then
strsql = "Select t.* From [" & rs!Table_Name & "] t Inner Join 01UMWELT On t.fall = [01UMWELT].fall Where [01UMWELT].Status = 4"
End If
Set rs3 = CurrentDb.OpenRecordset(strsql)
'End Function
strsql2 = "SELECT label.validcode FROM variablen s INNER JOIN label ON s.id=label.variablenid WHERE varname='" & astrFields(intIx) & "'"
Set db = OpenDatabase("C:\Documents and Settings\Desktop\Codebook.mdb")
Set rs2 = db.OpenRecordset(strsql2)
With rs2
.MoveLast
.MoveFirst
astrvalidcodes = rs2.GetRows(.RecordCount)
.Close '
End With
With rs3
.MoveFirst
While Not rs3.EOF
found = False
For Each v In astrvalidcodes
If v = .Fields(0) Then
found = True
Debug.Print .Fields(0)
Debug.Print .Fields(1)
Exit For
End If
Next
If Not found Then
msgbox "xxxxxxxxxxxxxxxx"
End If
End If
.MoveNext
Wend
End With
On Error GoTo 0 'End of special handling
Wend
Next intIx
End Sub
I'm getting a
Type Mismatch Runtime Error
in Set rs3 = CurrentDb.OpenRecordset(strsql)
I guess I'm mixing up ado and dao but I'm not certainly sure where it is.
Use the On Error statement that VBA supplies:
Sub TableTest
On Error Goto TableTest_Error
' ...code that can fail... '
Exit Sub
:TableTest_Error
If Err.Number = 3061 Then
Err.Clear()
DoSomething()
Else
MsgBox Err.Description ' or whatever you find appropriate '
End If
End Sub
Alternatively, you can switch off automatic error handling (e.g. breaking execution and displaying an error message) on a line-by-line basis:
Sub TableTest
' ... fail-safe code ... '
On Error Resume Next
' ...code that can fail... '
If Err.Number = 3061 Then
Err.Clear()
DoSomething()
Else
MsgBox Err.Description
End If
On Error Goto 0
' ...mode fail-safe code... '
End Sub
There are these statements available:
On Error Resume Next switches off VBA-integrated error handling (message box etc.) completely, execution simply resumes on the next line. Be sure to check for an error very early after you've used that, as a dangling error can disrupt the normal execution flow. Clear the error as soon as you caught it to prevent that.
On Error Goto <Jump Label> resumes execution at a given label, primarily used for per-function error handlers that catch all sorts of errors.
On Error Goto <Line Number> resumes at a given line number. Stay away from that, it's not useful, even dangerous.
On Error Goto 0 it's close cousin. Reinstates the VBA integrated error management (message box etc.)
EDIT
From the edited qestion, this is my proposal to solve your problem.
For Each FieldName In FieldNames ' assuming you have some looping construct here '
strsql3 = "SELECT " & FieldName & " FROM table"
On Error Resume Next
Set rs3 = CurrentDb.OpenRecordset(strsql3)
If Err.Number = 3061 Then
' Do nothing. We dont care about this error '
Err.Clear
Else
MsgBox "Uncaught error number " & Err.Number & " (" & Err.Description & ")"
Err.Clear
End If
On Error GoTo 0
Next FieldName
Be sure to clear the error in any case before you go on with a loop in the same Sub or Function. As I said, a dangling error causes code flow to become unexpected!
Rather than trapping the error, why not use the TableDefs to check for the field or use a mixture of ADO and DAO? ADO Schemas can provide a list of tables that contain the required field:
Function ListTablesContainingField()
Dim cn As New ADODB.Connection, cn2 As New ADODB.Connection
Dim rs As ADODB.Recordset, rs2 As ADODB.Recordset
Dim connString As String
Dim SelectFieldName
Set cn = CurrentProject.Connection
SelectFieldName = "Fall" 'For tksy '
'Get names of all tables that have a column called 'ID' '
Set rs = cn.OpenSchema(adSchemaColumns, _
Array(Empty, Empty, Empty, SelectFieldName))
'Show the tables that have been selected '
While Not rs.EOF
'Exclude MS system tables '
If Left(rs!Table_Name, 4) <> "MSys" Then
' Edit for tksy, who is using more than one forum '
If tdf.Name = "01UMWELT" Then
strSQL = "Select * From 01UMWELT Where Status = 5"
Else
strSQL = "Select a.* From [" & rs!Table_Name _
& "] a Inner Join 01UMWELT On a.fall = 01UMWELT.fall " _
& "Where 01UMWELT.Status = 5"
End If
Set rs2 = CurrentDb.OpenRecordset(strSQL)
Do While Not rs2.EOF
For i = 0 To rs2.Fields.Count - 1
If IsNull(rs2.Fields(i)) Then
rs2.Edit
rs2.Fields(i) = 111111
rs2.Update
End If
Next
rs2.MoveNext
Loop
End If
rs.MoveNext
Wend
rs.Close
Set cn = Nothing
End Function
Try this:
On Error Resume Next ' If an error occurs, move to next statement.
...statement that tries the select...
If (Err <> 0) Then
...act on error, or simply ignore if necessary...
End If
On Error Goto 0 ' Reset error handling to previous state.