I'm currently having problems with adding a new record in a table through VBA in Access. The VBA is used through a Button in a Form which has 2 Combination fields and 2 date fields.
Private Sub Schlussel_hinzufügen_Click()
On Error GoTo ErrHandler
Dim R As Recordset
Set R = CurrentDb.OpenRecordset("Schluesselhistorie")
R.AddNew
' Normally data is added to the record between these two
R.Close
Me.Requery
DoCmd.Close
Exit Sub
ErrHandler:
MsgBox "Couldn't save record!", vbCritical
End Sub
As soon as the R.AddNew is called the first record of the table is modified with the Data from the combination and date fields. A completely new record at the end of the table is created as well when
R![SLH_Schluessel_ID] = Me.Kombinationsfeld13.Value
R![SLH_Kontakt_ID] = Me.Kombinationsfeld15.Value
R![SLH_Datum_Ausgabe] = Me.SLH_Datum_Ausgabe.Value
R![SLH_Datum_Rueckgabe_Soll] = Me.SLH_Datum_Rueckgabe_Soll.Value
R.Update
is called though. I am kinda irritated as the former (first row event) shouldn't happen as I know and when code is added above both the first row is modified and a new record with these values is added.
The table is externally linked and the field names are in German.
Are there restrictions to the DAO where the Recordset used can't specify which line the Addnew should use. Or does the Addnew take the values of the Form to automatically add the Values to the table?
You should use the recordsetclone of the form:
Private Sub Schlussel_hinzufügen_Click()
On Error GoTo ErrHandler
Dim R As DAO.Recordset
Set R = Me.RecordsetClone
R.AddNew
' Normally data is added to the record between these two
R.UpDate
R.Close
Exit Sub
ErrHandler:
MsgBox "Couldn't save record!", vbCritical
End Sub
Related
As I can't solve my problem I'd like to ask someone more experienced.I created simple dialog (4 fields) to let the user enter few data. After clicking "Submit" button those data should be inserted into textboxes put ON THE SHEET (not on any dialog). How to refer to those sheet texboxes in code to insert those data? Other thing is deleting those data after clicking other button "Clear". Suppose it will be similar to inserting but how this piece of code should look like?
Thanks in advance.
The trick is to create a com.sun.star.drawing.TextShape object and add it to the Draw Page of the target sheet. The following works for me. You should be able to assign it to the appropriate button on your dialog.
Sub InsertTextBox()
Dim oDocument As Object
oDocument = ThisComponent
If oDocument.SupportsService("com.sun.star.sheet.SpreadsheetDocument") Then
Dim sText As String
sText = "Blah,blah, blah!"
Dim oPosition As New com.sun.star.awt.Point
oPosition.X = 1000
oPosition.Y = 1000
Dim oSize As New com.sun.star.awt.Size
oSize.Width = 10000
oSize.Height = 5000
Dim oTextShape As Object
oTextShape = oDocument.createInstance("com.sun.star.drawing.TextShape")
oTextShape.setPosition(oPosition)
oTextShape.setSize(oSize)
oTextShape.setPropertyValue("FillStyle", "SOLID")
oTextShape.Visible = 1
' Give it a name so you can find it again when you want to delete it
oTextShape.setPropertyValue("Name", "Thingy")
Dim oDrawPage As Object
oDrawPage = oDocument.getSheets().getByIndex(0).getDrawPage()
oDrawPage.add(oTextShape)
' Set the string of the text shape AFTER adding it to the
' draw page, otherwise the text will not be set.
oTextShape.setString(sText)
End If
End Sub
In the above routine the TextShape object was given the name "Thingy". You can obviously give it any name you like, but it should be unique. To delete it, you need to loop through all the objects in the draw page, find the one that is a TextShape and has the name you gave it (in this case "Thingy") and remove it. This can be done as follows:
Sub DeleteTextBox()
Dim oDocument As Object
oDocument = ThisComponent
If oDocument.SupportsService("com.sun.star.sheet.SpreadsheetDocument") Then
Dim oDrawPage As Object
oDrawPage = oDocument.getSheets().getByIndex(0).getDrawPage()
Dim oShape As Object
Dim i As Long
For i = (oDrawPage.getCount() - 1) To 0 Step -1
oShape = oDrawPage.getByIndex(i)
If oShape.SupportsService("com.sun.star.drawing.TextShape") Then
If StrComp(oShape.getPropertyValue("Name"), "Thingy") = 0 Then
oDrawPage.remove(oShape)
End If
End If
Next i
End If
End Sub
This will delete all objects of type TextShape and named "Thingy"
I am trying to create two tables which mirror changes made to any of them to one another automatically.
To that end, I added event listeners which are triggered when the cells of these tables are edited by the user.
Unfortunately, editing one of the tables causes LibreOffice to crash, even though the changes are indeed reflected correctly, as seen upon reopening the file.
I thought the crash might be due to a never-ending circular reference, but it still crashes after it has been made non-circular (by commenting out the relevant parts of the code so that changes are reflected only one way rather than both ways).
I noticed the code worked fine when writing to a cell that didn't have an event listener set to it.
How can I write to one of the cells with event listeners set to them without causing LibreOffice to crash?
You may want to download the following file. Please run Main and then try editing the cell C3 of the Planning sheet. The arbitrary string "C" should be written in the cell C4 of the Services sheet.
Here is a simplified version of the code :
REM ***** BASIC *****
const SERVICESSHEET_NUMBER = 2
const SERVICESSHEET_SERVICES_COLUMN = 2
Type cellStruct
columnNumber As Integer
rowNumber As Integer
End Type
Sub UpdateServicesSheet(editedCell As cellStruct, newValue As String)
Dim oSheets
Dim servicesSheet
oSheets = ThisComponent.getSheets()
servicesSheet = oSheets.getByIndex(SERVICESSHEET_NUMBER)
servicesSheet.getCellByPosition(SERVICESSHEET_SERVICES_COLUMN, 3).setString(newValue)
End Sub
Private oListener, cellRange as Object
Sub AddListener
Dim sheet, cell as Object
sheet = ThisComponent.Sheets.getByIndex(0) 'get leftmost sheet
servicesSheet = ThisComponent.Sheets.getByIndex(2)
cellRange = sheet.getCellrangeByName("C3")
oListener = createUnoListener("Modify_","com.sun.star.util.XModifyListener") 'create a listener
cellRange.addModifyListener(oListener) 'register the listener
cellRange = servicesSheet.getCellrangeByName("C4")
oListener = createUnoListener("Modify_","com.sun.star.util.XModifyListener") 'create a listener
cellRange.addModifyListener(oListener) 'register the listener
End Sub
global CircularReferenceAllowed As boolean
Sub Modify_modified(oEv)
Dim editedCell As cellStruct
Dim newValue As String
editedCell.columnNumber = 2
editedCell.rowNumber = 2
If CircularReferenceAllowed Then
CircularReferenceAllowed = false
UpdateServicesSheet(editedCell, "C")
End If
End Sub
Sub Modify_disposing(oEv)
End Sub
Sub RmvListener
cellRange.removeModifyListener(oListener)
End Sub
Sub Main
CircularReferenceAllowed = true
AddListener
End Sub
Crossposted to :
OpenOffice forums
LibreOffice discourse platform
It seems like the event trigger is within another event's function is causing the crash. In any case, the solution is to remove the listener, then add it back after modifying the other cell.
You do need to global the Listener and the Cell objects to make this work.
This code is simplified to work on C3 and C15 on the first sheet. It would also output some information on C14, which isn't really necessary for your purpose, but I use it to see what's happening. You need to adopt the according to what you need.
global goListener as Object
global goListener2 as Object
global goCellR as Object
global goCellR2 as Object
global goSheet as Object
global giRun as integer
global giUpd as Integer
Sub Modify_modified(oEv)
Dim sCurStr$
Dim sNewStr As String
'xRay oEv
giRun = giRun + 1
sCurStr = oEv.source.string
oCell = goSheet.getCellByPosition(2, 14)
If (oCell.getString() <> sCurStr) Then
' only update if it's different.
giUpd = giUpd + 1
goCellR2.removeModifyListener(goListener2)
oCell.setString(sCurStr)
goCellR2.addModifyListener(goListener2)
End If
sNewStr =sCurStr & " M1 Run=" & giRun & " Upd=" & giUpd
goSheet.getCellByPosition(2, 13).setString(sNewStr)
End Sub
Sub Modify2_modified(oEv)
Dim sCurStr$
Dim sNewStr As String
Dim oCell as Object
'xRay oEv
giRun = giRun + 1
sCurStr = oEv.source.string
oCell = goSheet.getCellByPosition(2, 2)
If (oCell.getString() <> sCurStr) Then
' only update if it's different.
giUpd = giUpd + 1
goCellR.removeModifyListener(goListener)
oCell.setString(sCurStr)
goCellR.addModifyListener(goListener)
End If
sNewStr =sCurStr & " M2 Run=" & giRun & " Upd=" & giUpd
goSheet.getCellByPosition(2, 13).setString(sNewStr)
End Sub
Sub Modify_disposing(oEv)
MsgBox "In Modify_disposing"
End Sub
Sub Modify2_disposing(oEv)
MsgBox "In Modify2_disposing"
End Sub
Sub RmvListener
MsgBox "In RmvListener"
goCellR.removeModifyListener(goListener)
goCellR2.removeModifyListener(goListener2)
End Sub
Sub AddListener
goSheet = ThisComponent.Sheets.getByIndex(0) 'get leftmost goSheet
'servicesSheet = ThisComponent.Sheets.getByIndex(2)
goCellR = goSheet.getCellrangeByName("C3")
goListener = createUnoListener("Modify_","com.sun.star.util.XModifyListener") 'create a listener
goCellR.addModifyListener(goListener) 'register the listener
goCellR2 = goSheet.getCellrangeByName("C15")
goListener2 = createUnoListener("Modify2_","com.sun.star.util.XModifyListener") 'create a listener
goCellR2.addModifyListener(goListener2) 'register the listener
End Sub
Sub Main
giRun = 0
giUpd = 0
AddListener
End Sub
For some odd reason, my combo boxes are not "preloaded" with content once the form is initialised, the user has to first close down the form and then open it again for the combo boxes to be prefilled. It's a bug that is starting to irritate the end user, any idea why would this happen? I've attached Boot to a button in my spreadsheet, which initialses the form. Code below:
In UserForm1
Private Sub UserForm1_Initialize()
Call GetPrimaryContact
Call GetSecondaryContact
End Sub
In Module1
Public itm1
Public itm2
Sub Boot()
UserForm1.Show
Call GetPrimaryContact
Call GetSecondaryContact
End Sub
Sub GetPrimaryContact()
Dim Col As New Collection
Dim i As Long
Dim CellVal As Variant
' Clear filters
ThisWorkbook.Sheets("Master").AutoFilter.ShowAllData
' Get last row
LastRow = ThisWorkbook.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
' Loop between all of column F to get unique values
For i = 3 To LastRow
CellVal = ThisWorkbook.Sheets("Master").Range("F" & i).Value
On Error Resume Next
Col.Add CellVal, Chr(34) & CellVal & Chr(34)
On Error GoTo 0
Next i
' Populate the first with primary contacts
For Each itm1 In Col
With UserForm1.ComboBox1
If IsEmpty(itm1) Then .AddItem "No Contact" Else .AddItem itm1
End With
Next
End Sub
Sub GetSecondaryContact()
Dim Col As New Collection
Dim i As Long
Dim CellVal As Variant
' Clear filters
ThisWorkbook.Sheets("Master").AutoFilter.ShowAllData
' Get last row
LastRow = ThisWorkbook.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
' Loop between all of column F to get unique values
For i = 3 To LastRow
CellVal = ThisWorkbook.Sheets("Master").Range("G" & i).Value
On Error Resume Next
Col.Add CellVal, Chr(34) & CellVal & Chr(34)
On Error GoTo 0
Next i
' Populate the first with primary contacts
For Each itm2 In Col
With UserForm1.ComboBox2
If Not IsEmpty(itm2) Then .AddItem itm2
End With
Next
End Sub
You should call the functions GetPrimaryContact and GetSecondaryContact on the form initialize event, this way the control's will be loaded as intended. See the example code below.
Sub Boot()
UserForm1.Show
End Sub
Private Sub UserForm_Initialize()
Call GetPrimaryContact
Call GetSecondaryContact
End Sub
I think your problem is that your Initialize code has Userform1_Initialize. It should only be written like Userform_Initialize and it will work.
And in the Sub boot put userform1.show last instead of first, If you stepping with F8 you will see that when you come to FormShow it stops there so it doesnt load your "Calls" until you close it and thats why you have them next time you start.
So far i have some code that allows a user to Hit F1 which loads a new form of the same properties and then hides the one the first one they had up, Hitting F2, allows the user to close the newly opened form and show the one they opened first. I would like a restriction that allows the user to open only 1 extra form if they hit F1 with 2 of the same forms open then a messagebox appears telling them to close the second form first otherwise allow it to be opened.
Here is what i have so far.
Private Sub Form_Load()
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyF1
'hides the current form
Me.Hide
'loads a new form with the same properties
Dim f As New Form1
Load f
'shows this new form
f.Show
'says that the second form is open
fOpen = True
Case vbKeyF2
'closes the second form
Unload Me
'says that the second form is closed
fOpen = False
'shows the first form you were on
Form1.Show
End Select
End Sub
Private Sub Form_QueryUnload(cancel As Integer, unloadmode As Integer)
'if your hitting "X" on second form then just close form2
If fOpen = False Then
Form1.Show
Else
'if your hitting "X" on main form close everything
Unload Me
End If
End Sub
Maybe something like if fOpen = true then disallow the user to hit F1? Not quite sure, but im close.
Forgive me if my VB6 is a little off, but you need to enumerate though the Forms collection to check to see if your form is already open...
Dim frm As Form
For Each frm In Forms
If frm.Name = "myForm" Then frm.Show()
Next frm
See this.
-- EDIT --
Just while I think on, to tune your code you could use a numeric iteration...
Dim f As Integer
Dim t As Integer
t = Forms.Count - 1
For f = 0 To t
If Forms(f).Name = "myForm" Then Forms(f).Show()
Next frm
-- EDIT 2 --
Just a further note on this. You may also want to introduce a counter so that you can check to see if there are two fields as in your original post...
Dim frm As Form
Dim c As Integer
For Each frm In Forms
If frm.Name = "myForm" Then
c = c + 1
If c = 2 Then
frm.Show()
Exit For 'Speed up the search if there are lots of forms
End If
End if
Next frm
I would like to execute some code when a user closes a form using the x button in the top right corner of the window (I have the form load when the excel spreadsheet is opened, and it hides Excel. I want to exit excel once the form is closed, or at least show excel again so the user may exit it manually)
Looking at the form properties, the Unload property is not present, nor am I able to figure out how to make a function which executes when the form is closed.
Unfortunately, coding this in VB is not an option, it must be VBA.
I'm aware of the code needed to unhide Excel or quit it outright, just not how to tie it to the unload event.
You can use QueryClose event of the UserForm as follows:
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
' Your codes
' Tip: If you want to prevent closing UserForm by Close (×) button in the right-top corner of the UserForm, just uncomment the following line:
' Cancel = True
End If
End Sub
You can also use vbFormControlMenu like this:
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
'Your code goes here
End If
End Sub
A colleague was able to provide the answer, including example here for everybody else
Private Sub userform_terminate()
'Code goes here
End Sub
You can use Unload Me in VBA to close a form. Just put the code to close Excel immediately following that.
Private Sub Form_Unload(Cancel As Integer)
Dim msgRes As VbMsgBoxResult
msgRes = MsgBox("Exit form ?", vbYesNo)
If msgRes = vbYes Then
'optional code
ElseIf msgRes = vbNo Then
Cancel = True
End If
End Sub
I was able to prevent the form from closing when the X button was click using the following:
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Cancel = MsgBox("Please confirm cancellation", vbOKCancel + vbQuestion) = vbCancel
End Sub
try something like this:-
Private Sub Form1_FormClosing(sender as Object, e as FormClosingEventArgs) _
Handles Form1.FormClosing
//Code you want to execute
End Sub