VBA code is getting error 462 - ms-access

I have the code below, in the OnClick event on a button that is located on a form. The code does the following:
In the sub form Forms! FrmFScomposition! PRODUCAO! [Prod_Cena_Guiao] (with an OLE object) I have a list of word documents, this list is updated with the help of a combobox. The code makes a Loop for all the documents and copies them to another sub form Forms! FrmFScomposition! SubfrmKitCenas! [FSKitCenasOLE], these documents are all in one. The code works fine, even if you repeat the process with the SAME data loaded. But when I choose another set of texts in the combobox, I get error 462, the first time I try the operation, but when I try again, the code works again. I'm tired of trying different possibilities, but I can not find a solution. Can someone help me or indicate something I'm missing? Below I will post the two subs that I am using. Thank you in advance for your attention.
code on button:
Private Sub Command54_Click()
Call DoResetKit
Dim FirstTime As Integer
FirstTime = 1
Me.FirstTimeBox = FirstTime
Forms!frmFScomposicao!PRODUCAO.SetFocus
DoCmd.RunCommand acCmdRecordsGoToFirst
For f = 1 To Forms!frmFScomposicao!PRODUCAO![tiroliro]
Call CompilarKitDiaGravacao
DoCmd.RunCommand acCmdRecordsGoToNext
Next f
DoCmd.RunCommand acCmdRecordsGoToFirst
End Sub
Code on first UDF
Public Sub CompilarKitDiaGravacao()
Dim CenasParaRecolha As Object
Dim DocumentoDestino As Object
Set CenasParaRecolha = Forms!frmFScomposicao!PRODUCAO![Prod_Cena_Guiao].Object.Application.WordBasic
Forms!frmFScomposicao!PRODUCAO![Prod_Cena_Guiao].Action = acOLEActivate
With CenasParaRecolha
Selection.WholeStory
Selection.Copy
End With
Set CenasParaRecolha = Nothing
If Forms!frmFScomposicao.FirstTimeBox = 1 Then
' Forms!frmFScomposicao!subfrmKitCenas![FSKitCenasOLE].Action = acOLEPaste
Set DocumentoDestino = Forms!frmFScomposicao!subfrmKitCenas![FSKitCenasOLE].Object.Application.WordBasic
Forms!frmFScomposicao!subfrmKitCenas![FSKitCenasOLE].Action = acOLEActivate
With DocumentoDestino
'Selection.WholeStory
'Selection.Delete
Selection.EndKey wdStory
Selection.InsertBreak Type:=wdSectionBreakContinuous
Selection.PasteAndFormat wdPasteDefault
End With
Set DocumentoDestino = Nothing
Forms!frmFScomposicao!FirstTimeBox = Forms!frmFScomposicao!FirstTimeBox + 1
Else
Set DocumentoDestino = Forms!frmFScomposicao!subfrmKitCenas![FSKitCenasOLE].Object.Application.WordBasic
Forms!frmFScomposicao!subfrmKitCenas![FSKitCenasOLE].Action = acOLEActivate
With DocumentoDestino
Selection.EndKey wdStory
Selection.InsertBreak 'Type:=wdSectionBreakContinuous
Selection.PasteAndFormat wdPasteDefault
End With
Set DocumentoDestino = Nothing
Forms!frmFScomposicao!FirstTimeBox = Forms!frmFScomposicao!FirstTimeBox + 1
End If
'Set CenasParaRecolha = Nothing
'Set DocumentoDestino = Nothing
End Sub
Code on second UDF
Public Sub DoResetKit()
Dim ResetKit As Object
Set ResetKit = Forms!frmFScomposicao!subfrmKitCenas![FSKitCenasOLE].Object.Application.WordBasic
Forms!frmFScomposicao!subfrmKitCenas![FSKitCenasOLE].Action = acOLEActivate
With ResetKit.Selection
Selection.WholeStory
Selection.Delete
End With
Set ResetKit = Nothing
End Sub

The working code for this is as follows:
Button Code:
Private Sub Command61_Click()
Dim ServerWordFS As Object
Set ServerWordFS = CreateObject("Word.Application")
Dim FirstTime As Integer
FirstTime = 1
For LoopCenasKit = 1 To Forms!frmFScomposicao!subfrmFScenas![tiroliro]
If FirstTime = 1 Then
Me.FirstTimeBox = FirstTime
Forms!frmFScomposicao!subfrmFScenas.SetFocus
Forms!frmFScomposicao!subfrmFScenas![EQUIPA].SetFocus
DoCmd.RunCommand acCmdRecordsGoToFirst
Call StartKit
DoCmd.RunCommand acCmdRecordsGoToNext
FirstTime = FirstTime + 1
Else
Call AddKit
DoCmd.RunCommand acCmdRecordsGoToNext
FirstTime = FirstTime + 1
End If
Next LoopCenasKit
ServerWordFS.Quit
End Sub
and two subs to create word doc wherever you want:
Public Sub StartKit()
Dim oAPP As Object
Dim oDoc As Word.Document
Dim cenaspararecolha As Object
Set oAPP = CreateObject(Class:="Word.Application")
With oAPP
.Visible = True
Set oDoc = .Documents.Add
oDoc.SaveAs "C:\Fserv\FolhaServiço", wdFormatDocument
End With
Forms!frmFScomposicao!subfrmFScenas![Prod_Cena_Guiao].SetFocus
Forms!frmFScomposicao!subfrmFScenas![Prod_Cena_Guiao].Action = acOLEActivate
Set cenaspararecolha = Forms!frmFScomposicao!subfrmFScenas![Prod_Cena_Guiao].Object.Application.WordBasic
With cenaspararecolha
Selection.WholeStory
Selection.Copy
End With
Forms!frmFScomposicao!subfrmFScenas![Prod_Cena_Guiao].Action = acOLEClose
With oAPP
.Selection.PasteSpecial DataType:=wdPasteRTF
End With
oDoc.Save
oDoc.Activate
oDoc.Close
oAPP.Quit
End Sub
Public Sub AddKit()
Dim oAPP As Object
Dim oDoc As Word.Document
Dim cenaspararecolha As Object
Set oAPP = CreateObject(Class:="Word.Application")
With oAPP
.Documents.Open Filename:="C:\Fserv\FolhaServiço.doc"
.Visible = True
.Selection.EndKey wdStory
.Selection.InsertBreak
End With
Forms!frmFScomposicao!subfrmFScenas![Prod_Cena_Guiao].SetFocus
Forms!frmFScomposicao!subfrmFScenas![Prod_Cena_Guiao].Action = acOLEActivate
Set cenaspararecolha = Forms!frmFScomposicao!subfrmFScenas![Prod_Cena_Guiao].Object.Application.WordBasic
With cenaspararecolha
Selection.WholeStory
Selection.Copy
End With
Forms!frmFScomposicao!subfrmFScenas![Prod_Cena_Guiao].Action = acOLEClose
With oAPP
.Selection.PasteSpecial DataType:=wdPasteRTF
Set oDoc = .ActiveDocument
oDoc.Save
End With
oDoc.Close
oAPP.Quit
End Sub

Related

VBA Access - Outlook cannot find name assigning a task through Access

I have successfully written code to create a task in Outlook. I used the code below in Private Sub OutlookTask_Click() define the recipient and it worked fine as well. However, I needed to add some custom field in my Outlook Task form. I changed the code to what is listed in Private Sub test1_Click(). It works fine assigning the task to myself using .save. When I am assigning to someone else I get the error outlook cannot find the name. The answer posted worked fine, Just needed to change MyItem to OlTask.
Private Sub OutlookTask_Click()
Dim OlApp As Outlook.Application
Dim OlTask As Outlook.TaskItem
Dim OlTaskProp As Outlook.UserProperty
Dim OlLocation As Object
Dim OlDelegate As Outlook.Recipient
Dim TName As String
Set OlApp = CreateObject("Outlook.Application")
Set OlTask = OlApp.CreateItem(olTaskItem)
Set OlTaskProp = OlLocation.UserProperties.Find("Mlocation")
TName = Me.Alias
'Set OlDelegate = OlTask.Recipients.Add(TName)
With OLTask
.Subject = Me.Item
.StartDate = Me.Start_Date
.DueDate = Me.Due_Date
.Status = TStatus
.Importance = TPriority
.ReminderSet = True
.ReminderTime = Me.Due_Date - 3 & " 8:00AM"
.Body = Me.Description
.UserProperties("MLocation") = Me.Location
If Me.Alias = "Troy" Then
.Save
Else
.Assign
Dim myDelegate As Outlook.Recipient
Set myDelegate = OlTask.Recipients.Add(TName)
myDelegate.Resolve
End If
If myDelegate.Resolved Then
.Send
Else
MsgBox "Name not Found"
End If
MsgBox "Task Successful"
End Sub
Private Sub test1_Click()
Dim OlApp As Outlook.Application
Dim objFolder As MAPIFolder
Dim OLTask As Outlook.TaskItem
Dim OlItems As Outlook.Items
Dim OlDelegate As Outlook.Recipient
Dim TName As String
Dim TStatus As Integer
Dim TPriority As Integer
Set OlApp = CreateObject("Outlook.Application")
Set objFolder = OlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderTasks)
Set OlItems = objFolder.Items
Set OLTask = OlItems.Add("IPM.Task.TroyTask")
TName = Me.Alias
Set OlDelegate = OLTask.Recipients.Add(TName)
With OLTask
.Subject = Me.Item
.StartDate = Me.Start_Date
.DueDate = Me.Due_Date
.Status = TStatus
.Importance = TPriority
.ReminderSet = True
.ReminderTime = Me.Due_Date - 3 & " 8:00AM"
.Body = Me.Description
.UserProperties("MLocation") = Me.Location
If Me.Alias = "Troy" Then
.Save
Else
.Assign
.Send
End If
End With
MsgBox "Task Successful"
End Sub
You seem to be submitting delegated task without sufficient preparation of its internal structures because Assign() is immediately followed by Send():
If Me.Alias = "Troy" Then
.Save
Else
.Assign
.Send ' problem
End If
In this case, recipients need to be resolved. See resolving of a task delegate's name visible in the working example. I adopted it without testing here:
If Me.Alias = "Troy" Then
.Save
Else
.Assign
Dim myDelegate As Outlook.Recipient 'added
Set myDelegate = OlTask.Recipients.Add(TName) 'added
myDelegate.Resolve 'added
If myDelegate.Resolved Then 'added
.Send
Else 'added
'report error here 'added
End If 'added
End If
The Resolve() call can be earlier in your code, this was just an illustration taken from the example.

If-Then-Else Opening Word Document

I'm trying to create an If-Then-Else statement in MS Access VBA.
This statement is to open a specific word document but if the word document does not exist then open a different word document.
Below is the code I have and it works if I get rid of the else but that doesn't solve my problem because I need the else statement.
Dim appword As Word.Application
Dim doc As Word.Document
Dim Path As String
Set appWord = GetObject(, "word.application")
If Err.Number <> 0 Then
Set appWord = New Word.Application
appWord.Visible = True
End If
If Value = "Excused" Then
Path = "C:\...existing docx"
Else
Path = "C:\...different docx"
End If
Set doc = appWord.Documents.Open(Path, , True)
Use appword.Documents.Add to return a new Document. You should also add an Error Handler when using GetObject. You may also consider using Len(Dir(Path)) to test if the file exists.
Dim appword As Word.Application
Dim doc As Word.Document
Dim Path As String
On Error Resume Next
Set appword = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set appword = New Word.Application
appword.Visible = True
End If
On Error GoTo 0
If Value = "Excused" Then
Path = "C:\...existing docx"
Set doc = appword.Documents.Open(Path, , True)
Else
Set doc = appword.Documents.Add
End If
Validate the document exists and if not add a new document.
Sub T()
Dim appword As Word.Application
Dim doc As Word.Document
Dim Path As String
Set appword = New Word.Application
appword.Visible = True
If Len(Dir("C:\...existing docx")) > 0 And Value = "Excused" Then
Path = "C:\...existing docx"
Set doc = appword.Documents.Open(Path, , True)
Else
Set doc = appword.Documents.Add
End If
End Sub

Add new sheets to the exported excel using vba and do a lookup between two sheets using access VBA [duplicate]

I am running a few modules of code in access and am writing data into
Excel. When I write the first time, data gets written properly. But again
when I try, the new data is written on top of the old data. What should I do to
insert a new sheet?
My existing code is
Dim objexcel As Excel.Application
Dim wbexcel As Excel.Workbook
Dim wbExists As Boolean
Dim objSht As Excel.Worksheet
Dim objRange As Excel.Range
Set objexcel = CreateObject("excel.Application")
On Error GoTo Openwb
wbExists = False
Set wbexcel = objexcel.Workbooks.Open("C:\REPORT1.xls")
Set objSht = wbexcel.Worksheets("Sheet1")
objSht.Activate
wbExists = True
Openwb:
On Error GoTo 0
If Not wbExists Then
objexcel.Workbooks.Add
Set wbexcel = objexcel.ActiveWorkbook
Set objSht = wbexcel.Worksheets("Sheet1")
End If
I think that the following code should do what you want. It's very similar to yours, except it uses the return values from the .Add methods to get the objects you want.
Public Sub YourSub()
Dim objexcel As Excel.Application
Dim wbexcel As Excel.Workbook
Dim wbExists As Boolean
Set objexcel = CreateObject("excel.Application")
'This is a bad way of handling errors. We should'
'instead check for the file existing, having correct'
'permissions, and so on, and actually stop the process'
'if an unexpected error occurs.'
On Error GoTo Openwb
wbExists = False
Set wbexcel = objexcel.Workbooks.Open("C:\REPORT1.xls")
wbExists = True
Openwb:
On Error GoTo 0
If Not wbExists Then
Set wbexcel = objexcel.Workbooks.Add()
End If
CopyToWorkbook wbexcel
EndSub
Private Sub CopyToWorkbook(objWorkbook As Excel.Workbook)
Dim newWorksheet As Excel.Worksheet
set newWorksheet = objWorkbook.Worksheets.Add()
'Copy stuff to the worksheet here'
End Sub

List Box items not highlighted when clicking on them

I have a list box in a form. Clicking on it causes the form to jump to another record. It supposed to highlight an item and jump to the correct record. Instead, it highlights, and then instantly clears the selection, although it still jumps to the record. When I use standard record selection buttons, items are correctly highlighted.
I read the index of selected item from .ListIndex property because Selected() does not work in a Single Selection mode when I test which item is selected. However, .ListIndex is read-only property and I use .Selected() to highlight the item.
Option Compare Database
Option Explicit
Private Sub Form_Current()
Call highlightListBox
End Sub
Private Sub lbListBox_Click()
Dim rs As DAO.Recordset
Dim indx As Long
Set rs = Me.RecordsetClone
If Not rs.BOF And Not rs.EOF Then
rs.MoveFirst
rs.FindFirst "[ID]=" & CStr(Me.lbListBox.ItemData(Me.lbListBox.ListIndex))
If Not rs.NoMatch Then
Me.Bookmark = rs.Bookmark
End If
End If
rs.Close
Set rs = Nothing
End Sub
Private Sub highlightListBox()
Dim lngIndx As Long
Dim lngI As Long
Dim bNoMatch As Boolean
lngIndx = 0
bNoMatch = True
If Me.NewRecord <> 0 Or IsNull(Me!ID) Then
For lngI = 0 To Me.lbListBox.ListCount - 1
Me.lbListBox.Selected(lngI) = False
Next lngI
Else
Do
lngIndx = lngIndx + 1
If CLng(Me.lbListBox.ItemData(lngIndx - 1)) = Me!ID Then
bNoMatch = False
End If
Loop Until CLng(Me.lbListBox.ItemData(lngIndx - 1)) = Me!ID Or lngIndx = Me.lbListBox.ListCount
End If
If Not bNoMatch Then
Me.lbListBox.Selected(lngIndx - 1) = True
End If
End Sub
I have been given a suggested about slightly different problem here but thanks to Remou I sorted this out.
The new code is following:
Option Compare Database
Option Explicit
Private Sub Form_Current()
Me.lbListBox = Me!ID
End Sub
Private Sub lbListBox_Click()
Dim rs As DAO.Recordset
Dim indx As Long
Set rs = Me.RecordsetClone
If Not rs.BOF And Not rs.EOF Then
rs.MoveFirst
rs.FindFirst "[ID]=" & CStr(Me.lbListBox.ItemData(Me.lbListBox.ListIndex))
If Not rs.NoMatch Then
Me.Bookmark = rs.Bookmark
End If
End If
Me.lbListBox = Me!ID
rs.Close
Set rs = Nothing
End Sub
I did not realise I could actually set a value to a list box using BoundColumn. By doing so, both highlighting and focusing is set. I am not sure but I think that MultiSelection has to be set to 0. In my case, the line
Me.lbListBox = Me!ID
does the job :)
I hope this answer can help someone else :)

Determine if Subform/Subreport Has a Form or a Report Loaded in MS Access

I have a Subform/Subreport control displayed on a Form in an Access 2010 database, and I use it to display both Forms and Reports. I have a few event handlers in which I need to know whether a Report is currently loaded into the Subform/Subreport control, or if it's a Form that's loaded. I have tried all of the following to no avail.
Any of the following conditions
If IsEmpty(NavigationSubform.Form) Then '...
If IsNull(NavigationSubform.Form) Then '...
If IsOject(NavigationSubform.Form) Then '...
If NavigationSubform.Form Is Nothing Then '...
If NavigationSubform.Form Is Null Then '...
If Nz(NavigationSubform.Form) Then '...
If (Not NavigationSubform.Form) = -1 Then '... This is a trick I use to check for uninitialized arrays
Results in
Run-time error '2467':
The expression you entered refers to an object that is closed or doesn't exist.
Is there some way that I can check whether a Subform/Subreport control currently has a Form or Report loaded without intentionally causing an error?
I don't believe that there is a way to reliably perform the check without error trapping, so you may want to wrap the code in a Public Function and put it into a regular VBA Module:
Public Function CheckSubformControlContents(ctl As SubForm) As String
Dim obj As Object, rtn As String
rtn = "None"
On Error Resume Next
Set obj = ctl.Form
If Err.Number = 0 Then
rtn = "Form"
Else
On Error Resume Next
Set obj = ctl.Report
If Err.Number = 0 Then
rtn = "Report"
End If
End If
Set obj = Nothing
On Error GoTo 0
CheckSubformControlContents = rtn
End Function
Then your form code can simply call CheckSubformControlContents(Me.NavigationSubform).
Here are two functions that work in Access 2013 for determining if a name is a Report or a Form.
Once that is determined the IsLoaded function of AllForms or AllReports can be used. Note that dbs is an object and rpt or frm are AccessObjects not forms or reports
Public Function IsForm(FormName As String) As Boolean
Dim dbs As Object
Dim frm As AccessObject
Set dbs = Application.CurrentProject
IsForm = False
For Each frm In Application.CurrentProject.AllForms
If frm.Name = FormName Then
IsForm = True
Exit For
End If
Next frm
Set frm = Nothing
Set dbs = Nothing
End Function
Public Function IsReport(ReportName As String) As Boolean
Dim dbs As Object
Dim rpt As AccessObject
Set dbs = Application.CurrentProject
IsReport = False
For Each rpt In Application.CurrentProject.AllReports
If rpt.Name = ReportName Then
IsReport = True
Exit For
End If
Next rpt
Set rpt = Nothing
Set dbs = Nothing
End Function
Here is a program that uses the above functions:
Public Sub EnumerateTaggedControls(ReportName As String, MyTag As String)
Dim dbs As Object
Dim rpt As Report
Dim frm As Form
Dim col As Controls
Dim ctl As Control
Dim left As Integer
Dim top As Integer
Dim width As Integer
Dim height As Integer
Dim tag As String
Dim i As Integer
Const format1 As String = "0000 "
Set dbs = Application.CurrentProject
If IsForm(ReportName) Then
If dbs.AllForms(ReportName).IsLoaded Then
DoCmd.OpenForm ReportName, acViewDesign
Set frm = Forms(ReportName)
Set col = frm.Controls
End If
Else
If dbs.AllReports(ReportName).IsLoaded Then
DoCmd.OpenReport ReportName, acViewDesign
Set rpt = Reports(ReportName)
Set col = rpt.Controls
Else
Debug.Print ReportName & " is not a loaded form or report."
Exit Sub
End If
End If
Set dbs = Nothing
Debug.Print Tab(53); "Left Top Width Height"
For Each ctl In col
With ctl
left = .Properties("Left")
top = .Properties("Top")
width = .Properties("Width")
height = .Properties("Height")
tag = Nz(.Properties("Tag"), vbNullString)
If MyTag = "" Then
i = 1
Else
i = InStr(1, tag, MyTag)
End If
If i > 0 Then
Debug.Print .Name & ">"; Tab(33); tag; Tab(53); Format(left, format1) & Format(top, format1) & Format(width, format1) & Format(height, format1)
End If
End With
Next ctl
Debug.Print "====================================================="
Set ctl = Nothing
Set rpt = Nothing
Set col = Nothing
Set frm = Nothing
End Sub
I hope this meets your requirements.