I have some code to build a basic report in access but, when I try to loop through all the reports with my variable rpt it skips the loop section, because nothing is assigned to the object. Any Ideas? What I need to get rpt to find the report with the caption qryDummy. Thanks in advance! :-)
Dim rptReport As Access.Report
Dim strCaption As String
Dim rpt As Report
CurrentDb.QueryDefs("qryDummy").SQL = strSQL
' Open dummy query to invoke NewObjectAutoReport command on it
' Put the report created to design view to make properties editable
With DoCmd
.OpenQuery "qryDummy", acViewNormal
.RunCommand acCmdNewObjectAutoReport
.Close acQuery, "qryDummy"
.RunCommand acCmdDesignView
End With
' Get reference to just created report
' !!!!!!!!!! This is the Section Giving me problems will !!!!!!!!!!!!!!
' !!!!!!!!!! not loop through all the reports. !!!!!!!!!!!!!!!!!!!!!!!!!
For Each rpt In Reports
If rpt.Caption = "qryDummy" Then Set rptReport = rpt
Next
With rptReport
' Create title control
With CreateReportControl(.Name, acLabel, _
acPageHeader, , ReportTitle, 0, 0)
.FontBold = True
.FontSize = 12
.SizeToFit
End With
' Create timestamp on footer
CreateReportControl .Name, acLabel, _
acPageFooter, , Now(), 0, 0
' Create page numbering on footer
With CreateReportControl(.Name, acTextBox, _
acPageFooter, , "='Page ' & [Page] & ' of ' & [Pages]", _
.Width - 1000, 0)
.SizeToFit
End With
' Detach the report from dummy query
.RecordSource = strSQL
' Set the report caption to autogenerated unique string
strCaption = GetUniqueReportName
If strCaption <> "" Then .Caption = strCaption
End With
DoCmd.RunCommand acCmdPrintPreview
Set rptReport = Nothing
EDIT:
Ok So I guess my problem will use this snippet of code as the report is left open when the VBA runs:
For Each rpt In Reports
If rpt.Caption = "qryDummy" Then Set rptReport = rpt
Next
The only problem I have is it is not assigning rptReport = rpt I get the error: rpt = nothing, which results in rpt.caption = "Object variable or with block variable not set". So it is like the open report is not being seen?
FYI Solved the Problem need to change rpt.caption to rpt.Name Thanks for the help!
Dim rpt As Report
For Each rpt In Reports
Debug.Print rpt.Name
Next
will only iterate through Reports that are currently open. To iterate through all reports you need to do
Dim rpt As Object
For Each rpt In Application.CurrentProject.AllReports
Debug.Print rpt.Name
Next
Related
Here is the situation:
Asp.Net Web Forms site using Open XML to read in a (via a stream) word document (docx). I then insert some text into the document and then write the file back out to a different location. It is then emailed to an end user. All of this works great.
The problem i am running into is that I can't the new file written by the site. I receive the following error:
"The process cannot access the file (file name here) because it is being used nt another process"
I have confirmed that it is the site (or IIS) that is holding on to the file.
Here is the code that reads the original file and generates the new file:
Private Function GetDocument(worddoc As String) As Integer
Dim byteArray As Byte() = File.ReadAllBytes("\\WEB-DEV-1\HR_Documents\" & worddoc)
Using Stream As New MemoryStream()
Stream.Write(byteArray, 0, CInt(byteArray.Length))
Try
'Set Row & Cell variables
Dim rowNum As Integer = 0
Dim cellNum As Integer = 0
'Set File Stream
Using doc As WordprocessingDocument = WordprocessingDocument.Open(Stream, True)
'Employee Name Insert
'Find first table in document
Dim tbl1 As Table = doc.MainDocumentPart.Document.Body.Elements(Of Table).First()
'First Row in tbl
Dim row As TableRow = tbl1.Elements(Of TableRow)().ElementAt(0)
'Find first cell in row
Dim cell As TableCell = row.Elements(Of TableCell)().ElementAt(0)
'Insert selected Employee Name
Dim p As Paragraph = cell.Elements(Of Paragraph)().First()
Dim r As Run = p.Elements(Of Run)().First()
Dim txt As Text = r.Elements(Of Text)().First()
txt.Text = "Employee Name: " & ddlEmployeeList.SelectedItem.Text
'Supervisor Name Insert
'Check for form
If ddlFormChoice.SelectedIndex <> 2 Then
'Reset row to supervisors row in table
row = tbl1.Elements(Of TableRow)().ElementAt(1)
ElseIf ddlFormChoice.SelectedIndex = 2 Then
'Reset row to supervisors row in table
row = tbl1.Elements(Of TableRow)().ElementAt(2)
End If
If ddlFormChoice.SelectedIndex <> 2 Then
'Reset cell to supervisor cell in row
cell = row.Elements(Of TableCell)().ElementAt(1)
ElseIf ddlFormChoice.SelectedIndex = 2 Then
'Reset cell to supervisor cell in row
cell = row.Elements(Of TableCell)().ElementAt(0)
End If
'Insert selected Employee Name
p = cell.Elements(Of Paragraph)().First()
r = p.Elements(Of Run)().First()
txt = r.Elements(Of Text)().First()
If ddlFormChoice.SelectedIndex <> 2 Then
txt.Text = "Supervisor: " & ddlSupervisorList.SelectedItem.Text
ElseIf ddlFormChoice.SelectedIndex = 2 Then
txt.Text = "Manager/Supervisor: " & ddlSupervisorList.SelectedItem.Text
End If
doc.Close()
End Using
'Save File to temp location
File.WriteAllBytes("\\WEB-DEV-1\HR_Documents\TempDocs\" & worddoc, Stream.ToArray())
Stream.Close()
Stream.Dispose()
Return 1
Catch ex As Exception
Return Nothing
End Try
End Using
End Function
I close the OpenXML doc and the stream as well dispose of the stream but when I try to delete the file from the main sub that called the function I get the error listed above.
What am I missing?? I closed the doc, the stream and disposed of the stream. Why is the site still holding the file?
Note here the line of code that trys to delete the file;
File.Delete("\\Web-Dev-1\HR_Documents\TempDocs\" & fileAttach)
So after most of the day i finally found out what the problem was. After the document was created, saved , and emailed it was being held by the email method. For some reason i thought that when the method finishes that it disposed of the Mail Message but this not the case.
Once I added the dispose line it all worked fine.
Only been Googling for almost two days. :|
So I am having a problem loading a drop down list in an asp.net web forms site. I am pulling the records from a SQL Server database. I am binding the results to a drop down list.
My problems stems from the fact that I am retrieving 21500 plus rows and it is causing a long delay to the point where the browser throws a message asking if I want to stop a long executing script. If I wait long enough, ~2 minutes it will come back but still runs very slow taking a long time scroll down through the list.
Here is the VB code for the SQL call:
Private Function GetCorInfo(field As String, tblname As String, Optional whereClause As String = "") As DataTable
Dim sqlCmdTxt As String = "Select " & field & " From " & tblname
Using conn As New SqlConnection(corConnection)
Try
conn.Open()
Catch ex As Exception
Master.message = "Unable to open SQL DB connection\nError: SQL101\nPlease contact the Help Desk for support.\n" & HttpUtility.JavaScriptStringEncode(ex.Message)
jsa.alertmessage(passedPage, Master.message)
End Try
Using sqlCmd As New SqlCommand
'Check for where clause
If whereClause <> "" Then
sqlCmdTxt = sqlCmdTxt & whereClause
If whereClause.Substring(7, 6) = "cornum" Then
sqlCmd.Parameters.AddWithValue("#cornum", ddl2.SelectedItem.Text)
End If
End If
If field = "cornum" Then
sqlCmdTxt = sqlCmdTxt & " Order By " & field & " Desc"
End If
sqlCmd.CommandText = sqlCmdTxt
sqlCmd.Connection = conn
Using sqlDT As New DataTable()
Using sqlDA As New SqlDataAdapter(sqlCmd)
Try
sqlDA.Fill(sqlDT)
Return sqlDT
Catch ex As Exception
conn.Close()
Master.message = "Unable to load list.\nError: SQL104\n" & HttpUtility.JavaScriptStringEncode(ex.Message)
jsa.alertmessage(passedPage, Master.message)
Return Nothing
End Try
End Using
End Using
End Using
End Using
End Function
Then when the data table is returned I am binding it to the drop down list using this code:
If Not IsNothing(dt) Then
'Set ddl
With ddl
'Turn on ddl
.Visible = True
'Set Data Source
.DataSource = dt
'Set Text Field
.DataTextField = field1
'Set Value Field
.DataValueField = field1
'Set variable to field value
'Bind Data
.DataBind()
'Assign Variable
field = ddl.SelectedItem.Text
'Check for ddl match
If whereClause <> "" AndAlso ddl1.SelectedIndex = 3 AndAlso ddl.ID = "ddl3" Then
.Items.FindByValue(field).Selected = True
ElseIf whereClause <> "" AndAlso ddl1.SelectedIndex = 3 AndAlso ddl.ID = "ddl4" Then
.Items.Insert(0, New ListItem("Select", "0"))
Else
'Insert first choice
.Items.Insert(0, New ListItem("Select", "0"))
End If
'Set to index 0
.SelectedIndex = 0
End With
Return 1
Else
Return -1
End If
Both sets of codes are run in functions.
How can I speed this up? I have looked at using Session and View State but the number of returned records would cause a bigger slow down if I do that.
Does anyone have any ideas?
Thanks in advance for the help.
So this what i finally did.
Placed a text box for the user to type in the first few char's of a new customer name. Then taking that I build a SQL query that only returns records that match the chars entered.
Much faster and only have at max 35 records...
I am VERY new to access and am working on a database. I have a form (frmHomeowner) with a bound multi-column combo box for zip codes (cboZip). The combo box is based on a query from tblZipCity [zipid (PK), zipcode, city, state] and the city and state text boxes get filled automatically once a zip code is selected.
I am trying to add the option of adding a new zipcode to the list with the Not In List event of the cboZip by opening the frmCitiesZip to add the new record :
Private Sub cboZip_NotInList(NewData As String, Response As Integer)
Dim Result
Dim Msg As String
Dim CR As String
CR = Chr$(13)
' Exit this subroutine if the combo box was cleared.
If NewData = "" Then Exit Sub
' Ask the user if he or she wishes to add the new zip code.
Msg = "'" & NewData & "' is not in the list." & CR & CR
Msg = Msg & "Do you want to add it?"
If MsgBox(Msg, vbQuestion + vbYesNo) = vbYes Then
' If the user chose Yes, start the CityZip form in data entry
' mode as a dialog form, passing the new zip code in
' NewData to the OpenForm method's OpenArgs argument. The
' OpenArgs argument is used in the homeowner form's Form_Load event
' procedure.
DoCmd.OpenForm "frmCitiesZip", , , , acAdd, acDialog, NewData
End If
' Look for the zip code the user created in the zip code form.
Result = DLookup("[zipcode]", "frmCitiesZip", _
"[zipcode]='" & NewData & "'")
If IsNull(Result) Then
' If the zip code was not created, set the Response argument
' to suppress an error message and undo changes.
Private Sub Form_Load()
If Not IsNull(Me.OpenArgs) Then
' If form's OpenArgs property has a value, assign the contents
' of OpenArgs to the zipcode field. OpenArgs will contain
' a zip code if this form is opened using the OpenForm
' method with an OpenArgs argument, as done in the homeowner
' form's cboZip_NotInList event procedure.
Me![zipcode] = Me.OpenArgs
End If
End Sub
But I seem to run into a problem around this line:
Result = DLookup("[zipcode]", "frmCitiesZip", _
"[zipcode]='" & NewData & "'")
If IsNull(Result) Then
When I type a zip code not currently on the list I get the prompt asking me if I want to add to the list but after I add it to the frmCitiesZip and close the form I get an error message:
Run-time error ‘3078’ saying that access cant find the input table or qry ‘frmCitiesZip’.
The frmCitiesZip is based on qryCitiesZip. Not sure what I am doing wrong. Any help would be appreciated. Thanks!
Folks- I'm relatively new to ASP.NET, and have a question that has stumped my peers-- folks much more experienced than myself.
My company created a website that uses iTextSharp to build and stream PDFs. The functionality works perfectly on my company's development and staging/test servers. The customer's functionality isn't working well, however. The customer's server streams a file where the PDF is missing the last block of data representing the EOF section. The PDF seems to build correctly, streams correctly, but when users open the PDF, the following error displays: 'There was an error opening this document. The file is damaged and could not be repaired.'
By comparing the PDFs in a text viewer (comparing the PDFs from my server vice the customer's server), I can see that the EOF section is missing from the customer's PDF. I'll also note that no errors are thrown during PDF creation, if that's helpful. To make matters more difficult, I have no access to the customer's servers, so I won't be able to interact with the systems directly.
The asp.net version is 3.5. Both of our servers (my company and the customer) are: running IIS7.5 on Server 2008R2; using iTextSharp is 5.1.2; and are configured for FIPS compatibility.
I've read dozens and dozens of posts detailing why a PDF isn't created properly, why it may not be streaming, and all things related, but I haven't seen this particular issue before. I guess what I need to know in the short-term is: 1) what can I provide to help diagnose the issue, 2) where is a good place to start looking for areas of concern?
Also, I updated to revision 5.5.3 last night; same results-- it works fine on my servers, but produces broken PDFs on the customer's server.
Code added:
Public Function BuildReport(ByVal tblReport As DataTable, _
ByRef memStream As MemoryStream, _
ByRef strErrMsg As String) As Boolean
Dim booOK As Boolean = True
strErrMsg = String.Empty
' Create document
Try
' Create writer (listens to the document and directs PDF stream)
memStream = New MemoryStream()
Dim msWriter As PdfWriter = PdfWriter.GetInstance(_document, memStream)
msWriter.CloseStream = False
'Create header
Dim ev As New itsEvents
msWriter.PageEvent = ev
' Set document metadata
_document.AddTitle(_strMetaTitle)
_document.AddSubject(_strMetaSubject)
_document.AddCreator(_strMetaApplication)
_document.AddAuthor(_strMetaAuthor)
' Open document, add document content, close document
_document.Open()
AddReportContent(tblReport)
_document.Close()
Catch ex As Exception
booOK = False
strErrMsg = ex.Message
End Try
Return booOK
End Function
Private Sub AddReportContent(ByVal tblReport As DataTable)
' Count report columns
Dim intReportColumns As Integer = 0
For Each col As DataColumn In tblReport.Columns
If ContainedInColumnMask(col.ColumnName) Then
intReportColumns += 1
End If
Next
' Build table
Dim table As PdfPTable
Dim cell As PdfPCell
Dim phrase As Phrase
If intReportColumns >= 1 Then
' Init table
table = New PdfPTable(intReportColumns)
' Add title to table
'phrase = New Phrase(_strMetaTitle, _fontLarge)
'cell = New PdfPCell(phrase)
'cell.Colspan = intReportColumns
'cell.HorizontalAlignment = 1 ' 0=Left, 1=Centre, 2=Right
'table.AddCell(cell)
' Add column headers to table
Dim i As Integer = 0
Dim intColWidth As Integer
Dim intColWidths As Integer() = New Integer(intReportColumns - 1) {}
Dim intColWidthTotal As Integer = 0
Dim strColName As String
For Each col As DataColumn In tblReport.Columns
If ContainedInColumnMask(col.ColumnName) Then
strColName = col.ColumnName
If (col.ExtendedProperties.Item("NOTEXTEXPORT") <> True) Then
If col.ExtendedProperties.Contains("FRIENDLYNAME") Then
strColName = col.ExtendedProperties.Item("FRIENDLYNAME")
End If
End If
phrase = New Phrase(strColName, _fontMedium)
cell = New PdfPCell(phrase)
cell.BorderWidth = 1
cell.BackgroundColor = iTextSharp.text.BaseColor.LIGHT_GRAY
'cell.BackgroundColor = iTextSharp.text.Color.LIGHT_GRAY
table.AddCell(cell)
intColWidth = GetColumnWidth(col, strColName, _fontMedium.Size, _fontSmall.Size)
intColWidths(i) = intColWidth
intColWidthTotal += intColWidth
i += 1
End If
Next
table.TotalWidth = intColWidthTotal
table.SetWidths(intColWidths)
' Add rows to table
For Each row As DataRow In tblReport.Rows
For Each col As DataColumn In tblReport.Columns
If ContainedInColumnMask(col.ColumnName) Then
phrase = New Phrase(SetBlankIfNothing(row.Item(col.ColumnName).ToString()), _fontSmall)
cell = New PdfPCell(phrase)
cell.BorderWidth = 0.5
table.AddCell(cell)
End If
Next
Next
Else
' Init table
table = New PdfPTable(1)
' Nothing to add to table
table.AddCell(String.Empty)
End If
' Add table to document
_document.Add(table)
End Sub
Public Sub New(ByVal strMetaTitle As String, _
ByVal strMetaSubject As String, _
ByVal strMetaApplication As String, _
ByVal strMetaAuthor As String, _
Optional ByVal strColumnMask As String = "")
GetStaticInfo()
_strMetaTitle = strMetaTitle
_strMetaSubject = strMetaSubject
_strMetaApplication = strMetaApplication
_strMetaAuthor = strMetaAuthor
_document = New iTextSharp.text.Document(_itsPage, _itsMarginLeft, _itsMarginRight, _itsMarginTop, _itsMarginBottom)
If strColumnMask <> "" And Not strColumnMask Is Nothing Then
_strColumnMask = strColumnMask
End If
End Sub
Public Sub New(ByVal strMetaTitle As String, _
ByVal strMetaSubject As String, _
ByVal strMetaApplication As String, _
ByVal strMetaAuthor As String, _
Optional ByVal strColumnMask As String = "")
GetStaticInfo()
_strMetaTitle = strMetaTitle
_strMetaSubject = strMetaSubject
_strMetaApplication = strMetaApplication
_strMetaAuthor = strMetaAuthor
_document = New iTextSharp.text.Document(_itsPage, _itsMarginLeft, _itsMarginRight, _itsMarginTop, _itsMarginBottom)
If strColumnMask <> "" And Not strColumnMask Is Nothing Then
_strColumnMask = strColumnMask
End If
End Sub
Have an assignment to do - it's to extract data from Lotus Notes DB including documents and their attachments. The purpose of this is to put it and store on the Sharepoint as a library.
So far I have managed to create a view and export the data for it to structure in Excel.
Also, I have looked up some Agents examples for extracting the attachments. With implementation of the below script, I managed to export the attachments:
Dim sDir As String
Dim s As NotesSession
Dim w As NotesUIWorkspace
Dim db As NotesDatabase
Dim dc As NotesDocumentCollection
Dim doc As NotesDocument
Sub Initialize
Set s = New NotesSession
Set w = New NotesUIWorkspace
Set db = s.CurrentDatabase
Set dc = db.UnprocessedDocuments
Set doc = dc.GetFirstDocument
Dim rtItem As NotesRichTextItem
Dim RTNames List As String
Dim DOCNames List As String
Dim itemCount As Integer
Dim sDefaultFolder As String
Dim x As Integer
Dim vtDir As Variant
Dim iCount As Integer
Dim j As Integer
Dim lngExportedCount As Long
Dim attachmentObject As Variant
x = MsgBox("This action will extract all attachments From the " & CStr(dc.Count) & _
" document(s) you have selected, And place them into the folder of your choice." & _
Chr(10) & Chr(10) & "Would you like To continue?", 32 + 4, "Export Attachments")
If x <> 6 Then Exit Sub
sDefaultFolder = s.GetEnvironmentString("LPP_ExportAttachments_DefaultFolder")
If sDefaultFolder = "" Then sDefaultFolder = "F:"
vtDir = w.SaveFileDialog( False, "Export attachments To which folder?", "All files|*.*", sDefaultFolder, "Choose Folder and Click Save")
If IsEmpty(vtDir) Then Exit Sub
sDir = StrLeftBack(vtDir(0), "\")
Call s.SetEnvironmentVar("LPP_ExportAttachments_DefaultFolder", sDir)
While Not (doc Is Nothing)
iCount = 0
itemCount = 0
lngExportedCount = 0
Erase RTNames
Erase DocNames
'Scan all items in document
ForAll i In doc.Items
If i.Type = RICHTEXT Then
Set rtItem = doc.GetfirstItem(i.Name)
If Not IsEmpty(rtItem.EmbeddedObjects) Then
RTNames(itemCount) = CStr(i.Name)
itemCount = itemCount +1
End If
End If
End ForAll
For j = 0 To itemCount-1
Set rtItem = Nothing
Set rtItem = doc.GetfirstItem(RTNames(j))
ForAll Obj In rtItem.EmbeddedObjects
If ( Obj.Type = EMBED_ATTACHMENT ) Then
Call ExportAttachment(Obj)
Call doc.Save( False, True )
'creates conflict doc if conflict exists
End If
End ForAll
Next
'Scan all items in document
ForAll i In doc.Items
If i.Type = ATTACHMENT Then
DOCNames(lngExportedCount) = i.Values(0)
lngExportedCount = lngExportedCount + 1
End If
End ForAll
For j% = 0 To lngExportedCount-1
Set attachmentObject = Nothing
Set attachmentObject = doc.GetAttachment(DOCNames(j%))
Call ExportAttachment(attachmentObject)
Call doc.Save( False, True )
'creates conflict doc if conflict exists
Next
Set doc = dc.GetNextDocument(doc)
Wend
MsgBox "Export Complete.", 16, "Finished"
End Sub
Sub ExportAttachment(o As Variant)
Dim sAttachmentName As String
Dim sNum As String
Dim sTemp As String
sAttachmentName = sDir & "\" & o.Source
While Not (Dir$(sAttachmentName, 0) = "")
sNum = Right(StrLeftBack(sAttachmentName, "."), 2)
If IsNumeric(sNum) Then
sTemp = StrLeftBack(sAttachmentName, ".")
sTemp = Left(sTemp, Len(sTemp) - 2)
sAttachmentName = sTemp & Format$(CInt(sNum) + 1, "##00") & _
"." & StrRightBack(sAttachmentName, ".")
Else
sAttachmentName = StrLeftBack(sAttachmentName, ".") & _
"01." & StrRightBack(sAttachmentName, ".")
End If
Wend
Print "Exporting " & sAttachmentName
'Save the file
Call o.ExtractFile( sAttachmentName )
End Sub
So the issue I do have right now is that these attachments are being saved to the same folder, which means that I would manually have to put them into right folders of library (several thousands). Could anyone help on how should I change the above code to have the attachments saved to separate folder for each document from DB?
Also for some reason that I cant find out below line is causing error pop up with "Object Variable not set":
sAttachmentName = sDir & "\" & o.Source
Would anyone know why it causes failure and stops the whole process?
You need to use the MkDir statement to create directory and extract attachments in the folder. Probably write something like:
MkDir sDir
You need to write code that create a new directory for each document (make sure you check if the directory exists, and preferably you make sure each directory has a unique name).
I wrote a tool like that, that exports all the fields of a document into XML, as well as attachments and embedded images. It can be set to separate each document into it's own directory.
You can read more about it ate the link below, perhaps you can get some ideas from the description. I use the UniversalID of teh document to get a unique folder name.
http://www.texasswede.com/websites/texasswede.nsf/Page/Notes%20XML%20Exporter