I recently built a program that connects to a remote SQL Server database. I discovered that the cursor type makes a huge difference in how fast the program runs. Initially, I used the adOpenStatic cursor. In some cases, the program took over 30 seconds to run seven simple queries and to render the results to some text boxes on an Access form. I changed the cursor type to adOpenForwardOnly, and the program took less than a second to run from then on. I have a "cleantext" function that scrubs the value entered by the user before it is used in the queries. Below is a simplified version of the code:
Dim cnx As ADODB.Connection
Set cnx = New ADODB.Connection
Dim serverName As String
Dim databaseName As String
Dim userId As String
Dim pwd As String
Dim strSQL as string
' DATABASE CONNECTION
serverName = "TheServerName"
databaseName = "TheDatabaseName"
userId = "TheUserId"
pwd = "ThePassword"
Set cnx = New ADODB.Connection
cnx.Open "Driver={SQL Server};Server=" & serverName & ";Database=" & databaseName & ";Uid=" & userId & ";Pwd=" & pwd & ";"
Dim rsADO As ADODB.Recordset
Set rsADO = New ADODB.Recordset
strSQL="SELECT a.field1, a.field2, a.field3" & _
" FROM someTable a" & _
" WHERE a.field1 = '" & cleantext(me.txtId.value) & "'"
rsADO.Open strSQL, cnx, adOpenForwardOnly
Do While Not rsADO.EOF
strDisplay = strDisplay & rsADO!field2 & " | " & rsADO!field3 & vbCrLf
rsADO.MoveNext
Loop
rsADO.Close
' Display the values in a scrollable text box
Me.txtHDHPosJobCodes.Value = strDisplay
strDisplay = ""
'CLOSE THE REMOTE DATABASE CONNECTION
Set rsADO = Nothing
cnx.Close
Set cnx = Nothing
Wednesday, March 6, 2019
Friday, June 15, 2018
Save an Excel file as a PDF using VBA
In this example, I'm opening an Excel workbook from another Office program (such as Access) and saving the workbook as a PDF:
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Open("template.xlsx", , False)
Set xlWS = xlWB.Sheets(1)
xlWS.Activate
With xlWS
filePathAndName = curPath & "\Reports\ReportName.pdf"
.PageSetup.FitToPagesTall = 1
.PageSetup.FitToPagesWide = 1
.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=filePathAndName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With
xlWB.Close
Set xlWB = Nothing
Set xlWS = Nothing
xlApp.Quit
Set xlApp = Nothing
Format cell borders in Excel using VBA
This example creates a header row with a heavy, black border and a light blue background.
With xlWS.Range("A1:A100")
.Interior.Color = RGB(194, 220, 255)
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlThick
.Borders(xlEdgeRight).Color = RGB(255, 255, 255)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlThick
.Borders(xlEdgeLeft).Color = RGB(255, 255, 255)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeRight).Color = RGB(255, 255, 255)
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeBottom).Color = RGB(255, 255, 255)
End With
Format cell text in Excel using VBA
Dim wsName As String
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Open(curPath & "\Template\template.xlsx", , False)
Set xlWS = xlWB.Sheets(1)
xlWS.Activate
With xlWS.Cells(row, col)
.Font.Name = "Cambria"
.Font.Bold = True
.Font.Size = 14
.Value = "Total Compensation Statement"
.VerticalAlignment = xlVAlignTop
.HorizontalAlignment = xlCenterAcrossSelection
End With
Use VBA to create a chart in Excel
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Set xlWS = xlWB.Sheets(1)
xlWB.Sheets("Sheet1").Activate
Dim chartObj As ChartObject
Set chartObj = xlWS.ChartObjects.Add _
(Left:=242, Width:=245, Top:=260, Height:=240)
chartObj.Chart.SetSourceData Source:=xlWB.Sheets("Sheet2").Range("A1:C2")
chartObj.Chart.ChartType = xl3DPie
chartObj.Chart.Elevation = 45
chartObj.Chart.ChartArea.Border.LineStyle = xlDash
chartObj.Chart.ChartArea.Border.LineStyle = xlNone
chartObj.Chart.SeriesCollection(1).ApplyDataLabels
chartObj.Chart.SeriesCollection(1).DataLabels.ShowPercentage = True
chartObj.Chart.SeriesCollection(1).DataLabels.ShowValue = False
chartObj.Chart.SeriesCollection(1).DataLabels.ShowCategoryName = True
chartObj.Chart.SeriesCollection(1).DataLabels.Font.Size = 8
chartObj.Chart.SeriesCollection(1).DataLabels.Font.Name = "Cambria"
chartObj.Chart.SeriesCollection(1).DataLabels.Font.Bold = False
chartObj.Chart.SeriesCollection(1).DataLabels.ShowLegendKey = -1
chartObj.Chart.SeriesCollection(1).DataLabels.Position = xlLabelPositionBestFit
chartObj.Chart.SetElement (msoElementLegendNone)
xlWB.SaveAs (curPath & "\Reports\ReportName.xlsx")
xlWB.Close
Set xlWB = Nothing
Set xlApp = Nothing
Use VBA to work with Microsoft Publisher
First, set a reference to the Microsoft Publisher Object Library in the VBA editor.
Create Publisher object variables:
Dim pubApp As Publisher.Application
Dim pubDoc As Publisher.Document
Open a Publisher document to use as a template:
Set pubApp = CreateObject("Publisher.Application")
Set pubDoc = pubApp.Open(FileName:=curPath & "\Templates\" _
& templateName, ReadOnly:=False, addtorecentfiles:=False, _
savechanges:=pbDoNotSaveChanges)
Find and replace text in Publisher:
Create Publisher object variables:
Dim pubApp As Publisher.Application
Dim pubDoc As Publisher.Document
Open a Publisher document to use as a template:
Set pubApp = CreateObject("Publisher.Application")
Set pubDoc = pubApp.Open(FileName:=curPath & "\Templates\" _
& templateName, ReadOnly:=False, addtorecentfiles:=False, _
savechanges:=pbDoNotSaveChanges)
Find and replace text in Publisher:
Private Sub replaceText(match As String, replace As String, ByRef pubDoc As Publisher.Document)
With pubDoc.Find
.Clear
.FindText = match
.ReplaceWithText = replace
.ReplaceScope = pbReplaceScopeOne
.Execute
End With
End Sub
With pubDoc.Find
.Clear
.FindText = match
.ReplaceWithText = replace
.ReplaceScope = pbReplaceScopeOne
.Execute
End With
End Sub
Call replaceText("<<Street>>", theStreet, pubDoc)
Add a table to a Publisher document:
pubDoc.Pages(1).Shapes.AddTable(NumRows:=5, _ NumColumns:=5, Left:=72, Top:=300, Width:=400, Height:=100) .Table.Columns(3).Cells(3).Fill.ForeColor.RGB = RGB _ (Red:=255, Green:=0, Blue:=0)
Add, format and populate rows in a Publisher table:
Dim rowNew as Row
Set rowNew = pubDoc.Pages(1).Shapes(1).Table.Rows.Add
rowNew.Cells(1).TextRange.Font.Name = "Montserrat"
rowNew.Cells(1).TextRange.Font.Size = 9
rowNew.Cells(1).TextRange.Text = someValue
Save the Publisher document as a PDF:
pubDoc.ExportAsFixedFormat pbFixedFormatTypePDF, _
docPathAndName, pbIntentStandard, False
Clean up Publisher objects:
pubDoc.Close
pubApp.Quit
Set pubApp = Nothing
Add a table to a Publisher document:
pubDoc.Pages(1).Shapes.AddTable(NumRows:=5, _ NumColumns:=5, Left:=72, Top:=300, Width:=400, Height:=100) .Table.Columns(3).Cells(3).Fill.ForeColor.RGB = RGB _ (Red:=255, Green:=0, Blue:=0)
Add, format and populate rows in a Publisher table:
Dim rowNew as Row
Set rowNew = pubDoc.Pages(1).Shapes(1).Table.Rows.Add
rowNew.Cells(1).TextRange.Font.Name = "Montserrat"
rowNew.Cells(1).TextRange.Font.Size = 9
rowNew.Cells(1).TextRange.Text = someValue
Save the Publisher document as a PDF:
pubDoc.ExportAsFixedFormat pbFixedFormatTypePDF, _
docPathAndName, pbIntentStandard, False
Clean up Publisher objects:
pubDoc.Close
pubApp.Quit
Set pubApp = Nothing
Thursday, June 14, 2018
Use VBA and Access Tables to Dynamically Populate a Publisher Template
I have a Publisher document that I need to send to a list of clients with information about their work comp rates for the upcoming year. The clients are categorized into several different types depending on a variety of factors which I won't get into here. A standard mail merge won't work because of the complexity of the process and the logic involved. I've omitted the business logic that organizes the clients and work comp rates into various categories.
The code creates a Publisher object, opens a pre-formatted Publisher document/template, iterates through an Access table and populates a table within Publisher from the Access data. A table with just the header already exists in the Publisher template. The code adds table rows and has to format the added rows so they are different from the header.
Once the document is complete, the code converts the Publisher doc to a PDF and closes Publisher without saving. A new document is created for each client in the table. Setting the "savechanges" parameter of the Publisher Open function to "pbDoNotSaveChanges" is critical, because it allows the Publisher template to be reused ad infinitum. Properly closing/cleaning up the Publisher doc and App is also critical. If your code does not properly open, save, and close the Publisher document, you will get all kinds of warnings and prompts from Publisher as the program runs.
The Optional parameter in the buildRatePage() function allowed me to test the function with a single client rather than waiting for an entire batch to run.
The first function below is called when a button is clicked. It calls the buildRatePage() function that does the actual work of building the work comp rate letters. A custom replaceText() function is called to find and replace text in the Publisher template which I've set up to look like merge fields in Word.
The key steps for working with Publisher in VBA are outlined below:
1) Set a reference to the Microsoft Publisher Object Library in the VBA editor.
2) Set up the variables:
Dim pubApp As Publisher.Application
Dim pubDoc As Publisher.Document
3) Instantiate the variables:
Set pubApp = CreateObject("Publisher.Application")
Set pubDoc = pubApp.Open(FileName:=curPath & "\Templates\" & templateName, ReadOnly:=False, addtorecentfiles:=False, savechanges:=pbDoNotSaveChanges)
4) Add, format and populate rows in a pre-existing table in Publisher:
Set rowNew = pubDoc.Pages(1).Shapes(1).Table.Rows.Add
rowNew.Cells(1).TextRange.Font.Name = "Montserrat"
rowNew.Cells(1).TextRange.Font.Size = 9
rowNew.Cells(1).TextRange.Text = someValue
5) Save the Publisher document as a PDF:
pubDoc.ExportAsFixedFormat pbFixedFormatTypePDF, docPathAndName, pbIntentStandard, False
6) Clean up:
pubDoc.Close
pubApp.Quit
Set pubApp = Nothing
Read on if you would like to see the details of how the program works:
Private Sub replaceText(match As String, replace As String, ByRef pubDoc As Publisher.Document)
With pubDoc.Find
.Clear
.FindText = match
.ReplaceWithText = replace
.ReplaceScope = pbReplaceScopeOne
.Execute
End With
End Sub
The code creates a Publisher object, opens a pre-formatted Publisher document/template, iterates through an Access table and populates a table within Publisher from the Access data. A table with just the header already exists in the Publisher template. The code adds table rows and has to format the added rows so they are different from the header.
Once the document is complete, the code converts the Publisher doc to a PDF and closes Publisher without saving. A new document is created for each client in the table. Setting the "savechanges" parameter of the Publisher Open function to "pbDoNotSaveChanges" is critical, because it allows the Publisher template to be reused ad infinitum. Properly closing/cleaning up the Publisher doc and App is also critical. If your code does not properly open, save, and close the Publisher document, you will get all kinds of warnings and prompts from Publisher as the program runs.
The Optional parameter in the buildRatePage() function allowed me to test the function with a single client rather than waiting for an entire batch to run.
The first function below is called when a button is clicked. It calls the buildRatePage() function that does the actual work of building the work comp rate letters. A custom replaceText() function is called to find and replace text in the Publisher template which I've set up to look like merge fields in Word.
The key steps for working with Publisher in VBA are outlined below:
1) Set a reference to the Microsoft Publisher Object Library in the VBA editor.
2) Set up the variables:
Dim pubApp As Publisher.Application
Dim pubDoc As Publisher.Document
3) Instantiate the variables:
Set pubApp = CreateObject("Publisher.Application")
Set pubDoc = pubApp.Open(FileName:=curPath & "\Templates\" & templateName, ReadOnly:=False, addtorecentfiles:=False, savechanges:=pbDoNotSaveChanges)
4) Add, format and populate rows in a pre-existing table in Publisher:
Set rowNew = pubDoc.Pages(1).Shapes(1).Table.Rows.Add
rowNew.Cells(1).TextRange.Font.Name = "Montserrat"
rowNew.Cells(1).TextRange.Font.Size = 9
rowNew.Cells(1).TextRange.Text = someValue
5) Save the Publisher document as a PDF:
pubDoc.ExportAsFixedFormat pbFixedFormatTypePDF, docPathAndName, pbIntentStandard, False
6) Clean up:
pubDoc.Close
pubApp.Quit
Set pubApp = Nothing
Read on if you would like to see the details of how the program works:
'------------------------------------------------------
Private Sub cmdCreateRPLetters_Click()
Me.lblLetterProc.Visible = True
Me.Repaint
Dim curPath As String
curPath = CurrentProject.Path
DoCmd.SetWarnings False
On Error Resume Next
Kill curPath & "\Letters\*.pdf"
On Error GoTo 0
' Testing
' Call buildRatePage("UtahOnly", "NoMod", "InsuredNoModTemplate.pub", "12-1315")
' Call buildRatePage("UtahOnly", "Mod", "InsuredModTemplate.pub", "13-1623")
' Call buildRatePage("MultiState", "Mod", "InsuredModTemplate.pub", "13-1540")
' Call buildRatePage("MultiState", "NoMod", "InsuredNoModTemplate.pub", "13-2291")
Call buildRatePage("UtahOnly", "NoMod", "InsuredNoModTemplate.pub")
Call buildRatePage("UtahOnly", "Mod", "InsuredModTemplate.pub")
Call buildRatePage("MultiState", "Mod", "InsuredModTemplate.pub")
Call buildRatePage("MultiState", "NoMod", "InsuredNoModTemplate.pub")
Call buildRatePage("MultiClient", "Mod", "InsuredModTemplate.pub")
Call buildRatePage("MultiClient", "NoMod", "InsuredNoModTemplate.pub")
Call buildRatePage("Idaho", "NoMod", "InsuredNoModTemplate.pub")
Call buildRatePage("Idaho", "Mod", "InsuredNoModTemplate.pub")
Me.lblLetterProc.Visible = False
Me.Repaint
MsgBox "Letters created. The Letters folder will be cleared the next time this program runs. Please save any letters" _
& " you want to keep to a new location."
End Sub
'-----------------------------------------------------
Private Sub buildRatePage(clientType As String, modType As String, templateName As String, Optional parentID As String)
Dim sql As String
Dim db As DAO.Database
Set db = CurrentDb
Dim rs As DAO.Recordset
Dim rs2 As DAO.Recordset
DoCmd.SetWarnings False
Dim pubApp As Publisher.Application
Dim pubDoc As Publisher.Document
Dim curPath As String
curPath = CurrentProject.Path
If Nz(parentID, "") <> "" Then
pID = " and parent_id = '" & parentID & "'"
Else
pID = ""
End If
sql = "SELECT DISTINCT parent_id, insured_name, type, mod_type FROM Rate_Page_Letters WHERE type = '" & clientType & "' and mod_type = '" & modType & "'" & pID
Set rs = db.OpenRecordset(sql)
Do While Not rs.EOF
If modType = "Mod" Then
sql = "SELECT DISTINCT * FROM Rate_Page_Letters WHERE parent_id = '" & rs!parent_id & "' and type = '" _
& rs!Type & "' and mod_type = '" & rs!mod_type & "' and mod2 <> 1"
Else
sql = "SELECT DISTINCT * FROM Rate_Page_Letters WHERE parent_id = '" & rs!parent_id & "' and type = '" & rs!Type & "' and mod_type = '" & rs!mod_type & "'"
End If
Set rs2 = db.OpenRecordset(sql)
Set pubApp = CreateObject("Publisher.Application")
Set pubDoc = pubApp.Open(FileName:=curPath & "\Templates\" & templateName, ReadOnly:=False, addtorecentfiles:=False, savechanges:=pbDoNotSaveChanges)
Do While Not rs2.EOF
Call replaceText("<<InsuredName>>", rs2!insured_name, pubDoc)
Call replaceText("<<PolicyNumber1>>", polNum, pubDoc)
' Populate the Publisher document
If templateName = "InsuredModTemplate.pub" Then
Call replaceText("<<Emod>>", rs2!mod2, pubDoc)
Set rowNew = pubDoc.Pages(1).Shapes(1).Table.Rows.Add
rowNew.Cells(1).TextRange.Font.Name = "Montserrat"
rowNew.Cells(1).TextRange.Font.Size = 9
rowNew.Cells(1).TextRange.Text = rs2!comp_code
rowNew.Cells(2).TextRange.Font.Name = "Montserrat"
rowNew.Cells(2).TextRange.Font.Size = 9
rowNew.Cells(2).TextRange.Text = rs2!code_desc
rowNew.Cells(3).TextRange.Font.Name = "Montserrat"
rowNew.Cells(3).TextRange.Font.Size = 9
rowNew.Cells(3).TextRange.Text = rs2!cur_yr_final_rate
rowNew.Cells(4).TextRange.Font.Name = "Montserrat"
rowNew.Cells(4).TextRange.Font.Size = 9
rowNew.Cells(4).TextRange.Text = rs2!cur_yr_mod_rate
Else
Set rowNew = pubDoc.Pages(1).Shapes(1).Table.Rows.Add
rowNew.Cells(1).TextRange.Font.Name = "Montserrat"
rowNew.Cells(1).TextRange.Font.Size = 9
rowNew.Cells(1).TextRange.Text = rs2!comp_code
rowNew.Cells(2).TextRange.Font.Name = "Montserrat"
rowNew.Cells(2).TextRange.Font.Size = 9
rowNew.Cells(2).TextRange.Text = rs2!code_desc
rowNew.Cells(3).TextRange.Font.Name = "Montserrat"
rowNew.Cells(3).TextRange.Font.Size = 9
rowNew.Cells(3).TextRange.Text = rs2!cur_yr_final_rate
End If
rs2.MoveNext
Loop
'Terrorism insurance rows at the end of the table
Set rowNew = pubDoc.Pages(1).Shapes(1).Table.Rows.Add
rowNew.Cells(1).Merge MergeTo:=rowNew.Cells(2)
rowNew.Cells(2).TextRange.Font.Name = "Montserrat"
rowNew.Cells(2).TextRange.Font.Size = 7
rowNew.Cells(2).TextRange.Text = "Terrorism Risk Insurance Act of 2002:"
rowNew.Cells(1).TextRange.Font.Name = "Montserrat"
rowNew.Cells(1).TextRange.Font.Size = 7
rowNew.Cells(1).TextRange.Text = ".01%"
Set rowNew = pubDoc.Pages(1).Shapes(1).Table.Rows.Add
rowNew.Cells(1).TextRange.Font.Name = "Montserrat"
rowNew.Cells(1).TextRange.Font.Size = 7
rowNew.Cells(1).TextRange.Text = "Domestic Terrorism, Earthquakes, and Catastrophic Industrial Accidents: "
rowNew.Cells(2).TextRange.Font.Name = "Montserrat"
rowNew.Cells(2).TextRange.Font.Size = 7
rowNew.Cells(2).TextRange.Text = ".01%"
rs2.Close
'Save as PDF
docName = curPath & "\Letters\" & clientType & "_" & modType & "-" & replace(cleantext(rs!insured_name), "/", "") & ".pdf"
pubDoc.ExportAsFixedFormat pbFixedFormatTypePDF, docName, pbIntentStandard, False
pubDoc.Close
pubApp.Quit
Set pubApp = Nothing
rs.MoveNext
Loop
rs.Close
End Sub
'-----------------------------------------------Private Sub replaceText(match As String, replace As String, ByRef pubDoc As Publisher.Document)
With pubDoc.Find
.Clear
.FindText = match
.ReplaceWithText = replace
.ReplaceScope = pbReplaceScopeOne
.Execute
End With
End Sub
Tuesday, February 14, 2017
Auto-populate a text box using a query
I have a small data warehouse I've built in MS Access 2016. I load new data in the warehouse every month, and I want to dynamically show users of the data warehouse the date range available for reports.
I created a label that says the following: "*Data loaded for January 1, 2016 through the end of".
Next, I created a textbox named txtMaxDate. I gave the textbox a transparent border and a font that matches the label above. I placed the textbox right after the label.
In the onLoad event of the form, I wrote the following code:
Private Sub Form_Load()
Dim sql As String
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim maxLoadDate As Date
Dim theYear As String
Dim theMonth As String
Set db = CurrentDb
sql = "SELECT MAX(PayYearMonth) as MaxDate FROM tblPaySummary"
Set rs = db.OpenRecordset(sql)
rs.MoveFirst
maxLoadDate = rs!MaxDate
theYear = year(maxLoadDate)
theMonth = MonthName(month(maxLoadDate))
Me.txtMaxDate.Value = theMonth & " " & theYear
End Sub
The code gets the most recent date from the database and displays the date in the text box.
I created a label that says the following: "*Data loaded for January 1, 2016 through the end of".
Next, I created a textbox named txtMaxDate. I gave the textbox a transparent border and a font that matches the label above. I placed the textbox right after the label.
In the onLoad event of the form, I wrote the following code:
Private Sub Form_Load()
Dim sql As String
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim maxLoadDate As Date
Dim theYear As String
Dim theMonth As String
Set db = CurrentDb
sql = "SELECT MAX(PayYearMonth) as MaxDate FROM tblPaySummary"
Set rs = db.OpenRecordset(sql)
rs.MoveFirst
maxLoadDate = rs!MaxDate
theYear = year(maxLoadDate)
theMonth = MonthName(month(maxLoadDate))
Me.txtMaxDate.Value = theMonth & " " & theYear
End Sub
The code gets the most recent date from the database and displays the date in the text box.
Thursday, April 16, 2015
VBA Function to Remove Non-Alphanumeric Characters
Occasionally, you'll run into data that has been entered with inadvertent carriage returns or other non-alphanumeric characters. Sometimes, these invisible characters can cause mysterious errors in your code. The solution is to use a function to remove any superfluous characters from the data.
The following function removes everything except for the characters indicated between the brackets. You can tweak the accepted character set as needed. The function works by looping through each character in the string and testing each character to see if it matches one of the characters listed between the square brackets.
Function cleanText(strText As String) As String
Dim valid as String
Dim test As String
valid = ""
test = ""
For i = 1 To Len(strText)
test = Mid(strText, i, 1)
'Only allow characters and spaces, not carriage returns or any other code
If test Like "[A-Z,a-z,0-9, ,.,/,~,@,#,$,%,^,&,*,(,),_,-,+,= ]" Then
valid = valid & test
End If
Next i
'Return the valid characters
cleanText = valid
End Function
The cleanText function uses the Visual Basic (VBA) "Like" operator. The Like operator is similar to using Regular Expressions and also has some similarities to the SQL Like operator. You can read more about the VBA Like operator on this page.
The following function removes everything except for the characters indicated between the brackets. You can tweak the accepted character set as needed. The function works by looping through each character in the string and testing each character to see if it matches one of the characters listed between the square brackets.
Function cleanText(strText As String) As String
Dim valid as String
Dim test As String
valid = ""
test = ""
For i = 1 To Len(strText)
test = Mid(strText, i, 1)
'Only allow characters and spaces, not carriage returns or any other code
If test Like "[A-Z,a-z,0-9, ,.,/,~,@,#,$,%,^,&,*,(,),_,-,+,= ]" Then
valid = valid & test
End If
Next i
'Return the valid characters
cleanText = valid
End Function
The cleanText function uses the Visual Basic (VBA) "Like" operator. The Like operator is similar to using Regular Expressions and also has some similarities to the SQL Like operator. You can read more about the VBA Like operator on this page.
VBA Regular Expression Phone Number Validator
This phone number validator validates numbers with or without dashes and with or without dots between the segments.
Public Function validatePhoneNo(phoneno As String) As Boolean
If phoneno <> "" Then
Dim re As RegExp
Dim matches As MatchCollection
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "^\(?\d{3}-?\.?\)?\s?\d{3}-?\.?\d{4}$"
Set matches = re.Execute(phoneno)
If matches.Count <> 1 Then
validatePhoneNo = False
Exit Function
End If
Else
validatePhoneNo = False
Exit Function
End If
validatePhoneNo = True
End Function
Public Function validatePhoneNo(phoneno As String) As Boolean
If phoneno <> "" Then
Dim re As RegExp
Dim matches As MatchCollection
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "^\(?\d{3}-?\.?\)?\s?\d{3}-?\.?\d{4}$"
Set matches = re.Execute(phoneno)
If matches.Count <> 1 Then
validatePhoneNo = False
Exit Function
End If
Else
validatePhoneNo = False
Exit Function
End If
validatePhoneNo = True
End Function
Use VBA to Automatically Set Dates in Form Fields
In this case, I have a report that requires a Begin Date and an End Date.
To make things easier for the user, I pre-fill the date fields with the date range most commonly used in the report. I use the Form_Load() event to automatically set the dates in the form fields.
Private Sub Form_Load()
Me.txtBegDt.Value = "1/1/" & Year(Date)
Me.txtEndDt.Value = Date
End Sub
The first line sets the Begin Date (txtBegDt) field to January 1 of the current year. The second line sets the End Date (txtEndDt) to the current date. Easy as that!
To make things easier for the user, I pre-fill the date fields with the date range most commonly used in the report. I use the Form_Load() event to automatically set the dates in the form fields.
Private Sub Form_Load()
Me.txtBegDt.Value = "1/1/" & Year(Date)
Me.txtEndDt.Value = Date
End Sub
The first line sets the Begin Date (txtBegDt) field to January 1 of the current year. The second line sets the End Date (txtEndDt) to the current date. Easy as that!
Shortcut to Open the VBA Editor
Using keyboard shortcuts saves a lot of time for things you do frequently. I use this shortcut every time I need to open the VBA editor in an Office Program:
Alt + F11
That's it. Practice using this shortcut a few times until it becomes second nature.
Alt + F11
That's it. Practice using this shortcut a few times until it becomes second nature.
Wednesday, May 21, 2014
Use Query Definitions to Create Dynamic Queries and Reports
The Begin and End dates in this query come from text boxes formatted as dates. The client list comes from a multi-select list box. The "qClaims" query is associated with the Claims Report. The query definition is fed a dynamic SQL statement built from the values selected by the user. The query definition makes it easy to generate a report from a dynamic query.
If Nz(Me.txtBegDt.Value, "") = "" Then
MsgBox "Please select a begin date."
Exit Sub
End If
If Nz(Me.txtEndDt.Value, "") = "" Then
MsgBox "Please select an end date."
Exit Sub
End If
DoCmd.Close acQuery, "qClaims", acSaveNo
DoCmd.Close acReport, "Claims Report"
Dim strList as String
Dim strsql As String
Dim strsql As String
Dim qdf As DAO.QueryDef
Set db = CurrentDb
Set qdf = db.QueryDefs("qClaims")
strList = ""
If Me.lstClients.ItemsSelected.Count > 0 Then
For Each client In Me.lstClients.ItemsSelected
strList = strList & "'" & Me.lstClients.ItemData(client) & "',"
Next client
strList = CStr(Trim(Left(strList, Len(strList) - 1))) ' Remove trailing comma
strList = " AND i.client_id IN (" & strList & ")"
Else
strList = ""
End If
strsql = "SELECT i.client_id, i.client_name, i.fname, i.lname, i.ssn," _
& " i.sep_reason, c.charge_qu, c.charge_yr, c.charge_amount" _
& " i.sep_reason, c.charge_qu, c.charge_yr, c.charge_amount" _
& " FROM tCharges c RIGHT JOIN tSeparation_Info i ON c.sep_ID = i.id" _
& " WHERE i.mail_date BETWEEN #" & [Forms]![Claims Report]![txtBegDt] _
& "# And #" & [Forms]![Claims Report]![txtEndDt] & "# " & strList _
& " ORDER BY i.client_name"
qdf.sql = strsql ' Set the sql of the query definition
DoCmd.OpenReport "Claims Report", acViewReport
Set db = Nothing
Set qdf = Nothing
Monday, February 3, 2014
Dynamic SQL statements
Dynamic SQL statements are great when you want to give end users maximum flexibility in creating their own reports. To build dynamic SQL statements, first declare variables for each clause of a SQL statement. Here we have variables for the SELECT, FROM, WHERE, and GROUP BY clauses. The allSQL variable will hold the completed SQL statement.
Dim selSQL As String
Dim fromSQL As String
Dim whereSQL As String
Dim groupSQL As String
Dim allSQL As String
Dim func As String
Next, we create a query definition object that will be used to run the dynamic SQL statement. "CustomReport" is a query I created in the visual query builder. It's just a container that will ultimately be used to run the dynamic SQL statement.
Dim qdf As DAO.QueryDef
Dim db As DAO.Database
Set db = CurrentDb
Set qdf = db.QueryDefs("CustomReport")
Next, initialize the SQL query strings.
selSQL = "SELECT m.PayYear"
fromSQL = " FROM client_list c INNER JOIN metrics m ON c.apexID = m.apexID"
groupSQL = " GROUP BY m.PayYear"
whereSQL = " WHERE 1=1"
Next, we will build the SELECT and GROUP BY portions of the SQL statement from values selected on a form:
In this case, we will Sum the Admin Fees and Gross Pay amounts and group those amounts by Salesforce Client, Quarter, and Salesforce Industry. We will be creating our report from a mini data warehouse we've built from data exported out of Salesforce.com and from another system called Summit Apex.
The following statements iterate through the different Display Value fields to retrieve the selected values and apply them to the SQL sections. Notice how the aggregate function is set in a variable called "func." If the user chooses "none" from the Aggregate Function radio group, then we will simply set the groupSQL string equal to "" near the end of the subprocedure.
' Time Detail Level
If Me.optTime.Value = 1 Then
selSQL = selSQL & ", m.PayMonth"
groupSQL = groupSQL & ", m.PayMonth"
ElseIf Me.optTime.Value = 2 Then
selSQL = selSQL & ", m.quarter"
groupSQL = groupSQL & ", m.quarter"
End If
' Client Level
If Me.optClLevel.Value = 1 Then
selSQL = selSQL & ", c.ApexID, c.ApexName"
groupSQL = groupSQL & ", c.ApexID, c.ApexName"
ElseIf Me.optClLevel.Value = 2 Then
selSQL = selSQL & ", c.ApexSFIDCaseSens, c.SalesforceName"
groupSQL = groupSQL & ", c.ApexSFIDCaseSens, c.SalesforceName"
End If
' Aggregate Function
If Me.optFunc.Value = 1 Then
func = "SUM"
ElseIf Me.optFunc.Value = 2 Then
func = "AVG"
ElseIf Me.optFunc.Value = 3 Then
func = "MAX"
ElseIf Me.optFunc.Value = 4 Then
func = "MIN"
ElseIf Me.optFunc.Value = 5 Then
func = ""
End If
' Metrics
For Each indx In Me.lstMetrics.ItemsSelected
If func = "" Then
selSQL = selSQL & ", m." & Me.lstMetrics.ItemData(indx)
Else
If func <> "SUM" Then
selSQL = selSQL & ", " & func & "(m." & Me.lstMetrics.ItemData(indx) & ") as " & Me.lstMetrics.ItemData(indx) & func & "PerMonth"
Else
selSQL = selSQL & ", " & func & "(m." & Me.lstMetrics.ItemData(indx) & ") as " & Me.lstMetrics.ItemData(indx) & "_" & func
End If
End If
Next indx
' Attributes
For Each indx In Me.lstAttr.ItemsSelected
selSQL = selSQL & ", c." & Me.lstAttr.ItemData(indx)
groupSQL = groupSQL & ", c." & Me.lstAttr.ItemData(indx)
Next indx
Next, we choose from a set of Attribute Filters to start building the WHERE clause.
In this case, we are limiting the results to the year 2013 and to the state of Utah. Here's the code to handle all of the Attribute filters:
' Date Range
If Nz(Me.txtBegDt.Value, "") <> "" And Nz(Me.txtEndDt.Value, "") <> "" Then
whereSQL = whereSQL & " AND m.MonthEndDate BETWEEN #" & Me.txtBegDt.Value & "# AND #" & Me.txtEndDt.Value & "#"
End If
'Company Number
If Nz(Me.txtCoNum.Value, "") <> "" Then
whereSQL = whereSQL & " AND c.ApexCompany = '" & Me.txtCoNum.Value & "'"
End If
' Industry Filter In
Dim industryList As String
industryList = ""
For Each indx In Me.lstIndustry.ItemsSelected
industryList = industryList & "'" & Me.lstIndustry.ItemData(indx) & "',"
Next indx
If industryList <> "" Then
whereSQL = whereSQL & " AND c.SFIndustry IN (" & Mid(industryList, 1, Len(industryList) - 1) & ")"
End If
' State Filter In
Dim stateList As String
stateList = ""
For Each indx In Me.lstState.ItemsSelected
stateList = stateList & "'" & Me.lstState.ItemData(indx) & "',"
Next indx
If stateList <> "" Then
whereSQL = whereSQL & " AND c.State IN (" & Mid(stateList, 1, Len(stateList) - 1) & ")"
End If
' City Filter In
Dim cityList As String
cityList = ""
For Each indx In Me.lstCity.ItemsSelected
cityList = cityList & "'" & Me.lstCity.ItemData(indx) & "',"
Next indx
If cityList <> "" Then
whereSQL = whereSQL & " AND c.city IN (" & Mid(cityList, 1, Len(cityList) - 1) & ")"
End If
' Zip Filter In
Dim zipList As String
zipList = ""
For Each indx In Me.lstZip.ItemsSelected
zipList = zipList & "'" & Me.lstZip.ItemData(indx) & "',"
Next indx
If zipList <> "" Then
whereSQL = whereSQL & " AND c.zip IN (" & Mid(zipList, 1, Len(zipList) - 1) & ")"
End If
' Apex Client Filter In
Dim apexClList As String
apexClList = ""
For Each indx In Me.lstApexClients.ItemsSelected
apexClList = apexClList & "'" & Me.lstApexClients.ItemData(indx) & "',"
Next indx
If apexClList <> "" Then
whereSQL = whereSQL & " AND c.ApexID IN (" & Mid(apexClList, 1, Len(apexClList) - 1) & ")"
End If
' Salesforce Client Filter In
Dim sfClList As String
sfClList = ""
For Each indx In Me.lstSFClients.ItemsSelected
sfClList = sfClList & "'" & Me.lstSFClients.ItemData(indx) & "',"
Next indx
If sfClList <> "" Then
whereSQL = whereSQL & " AND c.ApexSFIDCaseSens IN (" & Mid(sfClList, 1, Len(sfClList) - 1) & ")"
End If
By breaking the SQL statement down into its component parts, we can easily add additional filters and attributes to the form to give the end user maximum flexibility in building their own custom reports.
The following code concatenates each SQL section together to create the final statement:
allSQL = selSQL & fromSQL & whereSQL & groupSQL
I used debug.print to print the allSQL variable to the Immediate window in the VBA editor. Here's what the final SQL statement looks like:
SELECT m.PayYear, m.quarter, c.ApexSFIDCaseSens, c.SalesforceName, SUM(m.AdminFees) as AdminFees_SUM, SUM(m.GrossPay) as GrossPay_SUM, c.SFIndustry
FROM client_list c INNER JOIN metrics m ON c.apexID = m.apexID
WHERE 1=1 AND m.MonthEndDate BETWEEN #1/1/2013# AND #12/31/2013# AND c.State IN ('UT') GROUP BY m.PayYear, m.quarter, c.ApexSFIDCaseSens, c.SalesforceName, c.SFIndustry
In order to run the SQL statement and show the report, we feed the SQL statement to the Query Definition object:
qdf.SQL = allSQL
Finally, we open the report and display the output:
DoCmd.OpenQuery "CustomReport", acViewNormal
We could just as easily export the report to Excel as follows:
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "CustomReport", curPath & "\Excel Exports\CustomReport.xlsx"
Dim selSQL As String
Dim fromSQL As String
Dim whereSQL As String
Dim groupSQL As String
Dim allSQL As String
Dim func As String
Next, we create a query definition object that will be used to run the dynamic SQL statement. "CustomReport" is a query I created in the visual query builder. It's just a container that will ultimately be used to run the dynamic SQL statement.
Dim qdf As DAO.QueryDef
Dim db As DAO.Database
Set db = CurrentDb
Set qdf = db.QueryDefs("CustomReport")
Next, initialize the SQL query strings.
selSQL = "SELECT m.PayYear"
fromSQL = " FROM client_list c INNER JOIN metrics m ON c.apexID = m.apexID"
groupSQL = " GROUP BY m.PayYear"
whereSQL = " WHERE 1=1"
Next, we will build the SELECT and GROUP BY portions of the SQL statement from values selected on a form:
In this case, we will Sum the Admin Fees and Gross Pay amounts and group those amounts by Salesforce Client, Quarter, and Salesforce Industry. We will be creating our report from a mini data warehouse we've built from data exported out of Salesforce.com and from another system called Summit Apex.
The following statements iterate through the different Display Value fields to retrieve the selected values and apply them to the SQL sections. Notice how the aggregate function is set in a variable called "func." If the user chooses "none" from the Aggregate Function radio group, then we will simply set the groupSQL string equal to "" near the end of the subprocedure.
' Time Detail Level
If Me.optTime.Value = 1 Then
selSQL = selSQL & ", m.PayMonth"
groupSQL = groupSQL & ", m.PayMonth"
ElseIf Me.optTime.Value = 2 Then
selSQL = selSQL & ", m.quarter"
groupSQL = groupSQL & ", m.quarter"
End If
' Client Level
If Me.optClLevel.Value = 1 Then
selSQL = selSQL & ", c.ApexID, c.ApexName"
groupSQL = groupSQL & ", c.ApexID, c.ApexName"
ElseIf Me.optClLevel.Value = 2 Then
selSQL = selSQL & ", c.ApexSFIDCaseSens, c.SalesforceName"
groupSQL = groupSQL & ", c.ApexSFIDCaseSens, c.SalesforceName"
End If
' Aggregate Function
If Me.optFunc.Value = 1 Then
func = "SUM"
ElseIf Me.optFunc.Value = 2 Then
func = "AVG"
ElseIf Me.optFunc.Value = 3 Then
func = "MAX"
ElseIf Me.optFunc.Value = 4 Then
func = "MIN"
ElseIf Me.optFunc.Value = 5 Then
func = ""
End If
' Metrics
For Each indx In Me.lstMetrics.ItemsSelected
If func = "" Then
selSQL = selSQL & ", m." & Me.lstMetrics.ItemData(indx)
Else
If func <> "SUM" Then
selSQL = selSQL & ", " & func & "(m." & Me.lstMetrics.ItemData(indx) & ") as " & Me.lstMetrics.ItemData(indx) & func & "PerMonth"
Else
selSQL = selSQL & ", " & func & "(m." & Me.lstMetrics.ItemData(indx) & ") as " & Me.lstMetrics.ItemData(indx) & "_" & func
End If
End If
Next indx
' Attributes
For Each indx In Me.lstAttr.ItemsSelected
selSQL = selSQL & ", c." & Me.lstAttr.ItemData(indx)
groupSQL = groupSQL & ", c." & Me.lstAttr.ItemData(indx)
Next indx
Next, we choose from a set of Attribute Filters to start building the WHERE clause.
' Date Range
If Nz(Me.txtBegDt.Value, "") <> "" And Nz(Me.txtEndDt.Value, "") <> "" Then
whereSQL = whereSQL & " AND m.MonthEndDate BETWEEN #" & Me.txtBegDt.Value & "# AND #" & Me.txtEndDt.Value & "#"
End If
'Company Number
If Nz(Me.txtCoNum.Value, "") <> "" Then
whereSQL = whereSQL & " AND c.ApexCompany = '" & Me.txtCoNum.Value & "'"
End If
' Industry Filter In
Dim industryList As String
industryList = ""
For Each indx In Me.lstIndustry.ItemsSelected
industryList = industryList & "'" & Me.lstIndustry.ItemData(indx) & "',"
Next indx
If industryList <> "" Then
whereSQL = whereSQL & " AND c.SFIndustry IN (" & Mid(industryList, 1, Len(industryList) - 1) & ")"
End If
' State Filter In
Dim stateList As String
stateList = ""
For Each indx In Me.lstState.ItemsSelected
stateList = stateList & "'" & Me.lstState.ItemData(indx) & "',"
Next indx
If stateList <> "" Then
whereSQL = whereSQL & " AND c.State IN (" & Mid(stateList, 1, Len(stateList) - 1) & ")"
End If
' City Filter In
Dim cityList As String
cityList = ""
For Each indx In Me.lstCity.ItemsSelected
cityList = cityList & "'" & Me.lstCity.ItemData(indx) & "',"
Next indx
If cityList <> "" Then
whereSQL = whereSQL & " AND c.city IN (" & Mid(cityList, 1, Len(cityList) - 1) & ")"
End If
' Zip Filter In
Dim zipList As String
zipList = ""
For Each indx In Me.lstZip.ItemsSelected
zipList = zipList & "'" & Me.lstZip.ItemData(indx) & "',"
Next indx
If zipList <> "" Then
whereSQL = whereSQL & " AND c.zip IN (" & Mid(zipList, 1, Len(zipList) - 1) & ")"
End If
' Apex Client Filter In
Dim apexClList As String
apexClList = ""
For Each indx In Me.lstApexClients.ItemsSelected
apexClList = apexClList & "'" & Me.lstApexClients.ItemData(indx) & "',"
Next indx
If apexClList <> "" Then
whereSQL = whereSQL & " AND c.ApexID IN (" & Mid(apexClList, 1, Len(apexClList) - 1) & ")"
End If
' Salesforce Client Filter In
Dim sfClList As String
sfClList = ""
For Each indx In Me.lstSFClients.ItemsSelected
sfClList = sfClList & "'" & Me.lstSFClients.ItemData(indx) & "',"
Next indx
If sfClList <> "" Then
whereSQL = whereSQL & " AND c.ApexSFIDCaseSens IN (" & Mid(sfClList, 1, Len(sfClList) - 1) & ")"
End If
By breaking the SQL statement down into its component parts, we can easily add additional filters and attributes to the form to give the end user maximum flexibility in building their own custom reports.
The following code concatenates each SQL section together to create the final statement:
allSQL = selSQL & fromSQL & whereSQL & groupSQL
I used debug.print to print the allSQL variable to the Immediate window in the VBA editor. Here's what the final SQL statement looks like:
SELECT m.PayYear, m.quarter, c.ApexSFIDCaseSens, c.SalesforceName, SUM(m.AdminFees) as AdminFees_SUM, SUM(m.GrossPay) as GrossPay_SUM, c.SFIndustry
FROM client_list c INNER JOIN metrics m ON c.apexID = m.apexID
WHERE 1=1 AND m.MonthEndDate BETWEEN #1/1/2013# AND #12/31/2013# AND c.State IN ('UT') GROUP BY m.PayYear, m.quarter, c.ApexSFIDCaseSens, c.SalesforceName, c.SFIndustry
In order to run the SQL statement and show the report, we feed the SQL statement to the Query Definition object:
qdf.SQL = allSQL
Finally, we open the report and display the output:
DoCmd.OpenQuery "CustomReport", acViewNormal
We could just as easily export the report to Excel as follows:
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "CustomReport", curPath & "\Excel Exports\CustomReport.xlsx"
Wednesday, November 20, 2013
How to make a household budget calculator with Excel
- Open a new Excel workbook.
- Name the first worksheet Expenditures.
- Name the second worksheet Budget Calculations.
- Delete any remaining worksheets.
- On the first worksheet, add the text Expenditures to cell A1.
- Merge and center A1 across three columns and two rows.
- Add the following text to cells A3, B3, and C3: Category, Amount, Description.
- Set up the Budget Calculations worksheet as follows:
- On the Expenditures worksheet, add the following data validation to cell A4. Apply the same validation to 100 or so cells in the same column. (Click the bottom right corner of cell A4 and drag down to apply the validation to the column.) The data validation will add a dropdown list in column A of the Expenditures worksheet that is comprised of the categories from column A in the Budget Calculations worksheet.
- Add the following formula to cell C4 of the Budget Calculations worksheet:
- =SUMIF(Expenditures!$A$4:$B$151,A4,Expenditures!$B$4:$B$151)
- The above formula adds up the expenditures for each category entered into column A of the Budget Calculations spreadsheet. Drag the formula down the column.
- Add categories to column A of the Budget Calculations according to the way you want to categorize expenditures. These can be changed as needed.
- Add the amounts you want to budget for each category to column B of the Budget Calculations.
- Add the following formula to cell D4 to calculate the Remaining amount: =B4 - C4
- Drag the formula down.
- Add totals to the bottom row to show the total Budgeted amount, the total Actual amount spent, and the total Remaining.
- Click here to download the file: https://sites.google.com/site/benberginsfiles/Budget%20Calculator.xlsx
- You can save the file as a template so you can create a fresh copy each month. Just go to Save As and choose Excel Template.
- I usually name each file after the year and month I'm tracking: 2013-12_Budget.xlsx for example.
Saturday, November 9, 2013
How to secure your Access application using Active Directory
If your network is part of an Active Directory domain, then you can easily use domain groups as a means of securing your Microsoft Access application.
The IsMember function determines if a logged in user is a member of a specific Active Directory group or not.
Function IsMember(strDomain As String, strGroup As String, strMember As String) As Boolean
Dim adGrp As Object
Dim strPath As String
strPath = "WinNT://" & strDomain & "/"
Set adGrp = GetObject(strPath & strGroup & ",group")
IsMember = adGrp.IsMember(strPath & strMember)
End Function
If IsMember("mydomain.com", "Accounting", Environ("Username")) Then
' Allow access to sensitive information
Else
' Deny access to sensitive information
End If
You can use the IsMember function to show or hide forms, to show or hide buttons, to add filters to SQL code, etc. Here are some code samples of ways you might secure your application using Active Directory groups:
This code hides and disables a button when the form loads:
Private Sub Form_Load()
If IsMember("mydomain.com", "Domain Admins", Environ("Username")) Then
Me.cmdLoadData.Visible = True
Me.cmdLoadData.Enabled = True
Else
Me.cmdLoadData.Visible = False
Me.cmdLoadData.Enabled = False
End If
End Sub
You can also use the IsMember function as you build a dynamic SQL Statement. The following code allows Executives to see anyone's salary information but only allows others to see their own salary information.
If IsMember("mydomain.com", "Executives", Environ("Username")) Then
strSQL = "SELECT * FROM SalaryInfo"
Else
strSQL = "SELECT * FROM SalaryInfo" _
& " WHERE Username = '" & Environ("Username") & "'"
End If
The IsMember function determines if a logged in user is a member of a specific Active Directory group or not.
Function IsMember(strDomain As String, strGroup As String, strMember As String) As Boolean
Dim adGrp As Object
Dim strPath As String
strPath = "WinNT://" & strDomain & "/"
Set adGrp = GetObject(strPath & strGroup & ",group")
IsMember = adGrp.IsMember(strPath & strMember)
End Function
If IsMember("mydomain.com", "Accounting", Environ("Username")) Then
' Allow access to sensitive information
Else
' Deny access to sensitive information
End If
You can use the IsMember function to show or hide forms, to show or hide buttons, to add filters to SQL code, etc. Here are some code samples of ways you might secure your application using Active Directory groups:
This code hides and disables a button when the form loads:
Private Sub Form_Load()
If IsMember("mydomain.com", "Domain Admins", Environ("Username")) Then
Me.cmdLoadData.Visible = True
Me.cmdLoadData.Enabled = True
Else
Me.cmdLoadData.Visible = False
Me.cmdLoadData.Enabled = False
End If
End Sub
You can also use the IsMember function as you build a dynamic SQL Statement. The following code allows Executives to see anyone's salary information but only allows others to see their own salary information.
If IsMember("mydomain.com", "Executives", Environ("Username")) Then
strSQL = "SELECT * FROM SalaryInfo"
Else
strSQL = "SELECT * FROM SalaryInfo" _
& " WHERE Username = '" & Environ("Username") & "'"
End If
Monday, November 4, 2013
How to save a Word document as a PDF using Visual Basic (VBA)
Set a reference to the Microsoft Word object library.
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
Dim pdfName As String
Dim curPath as String
curPath = CurrentProject.Path
Set wordApp = CreateObject("Word.Application")
Set wordDoc = wordApp.Documents.Open(curPath & "\Templates\Some Doc.docx")
pdfName= curPath & "\Some Folder\Converted Doc.pdf"
wordDoc.ExportAsFixedFormat OutputFileName:=pdfName, ExportFormat:= _
wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent, IncludeDocProps:=True
wordDoc.Close saveChanges:=False
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
Dim pdfName As String
Dim curPath as String
curPath = CurrentProject.Path
Set wordApp = CreateObject("Word.Application")
Set wordDoc = wordApp.Documents.Open(curPath & "\Templates\Some Doc.docx")
wordDoc.ExportAsFixedFormat OutputFileName:=pdfName, ExportFormat:= _
wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent, IncludeDocProps:=True
wordDoc.Close saveChanges:=False
How to delete files with Visual Basic (VBA)
dim folderName as String
folderName = "\\Server Name\Share Name\Some Folder\Old Files\"
On Error Resume Next
Kill folderName & "*.*"
On Error GoTo 0
To delete a specific file type, replace the second "*" wildcard with the file extension of the files you want to delete:
On Error Resume Next
Kill folderName & "*.xlsx"
On Error GoTo 0
Be careful with the Kill function as you can inadvertently delete valuable files. Make sure you specify the folder from which you want to delete files. And it's best to specify the file type or the file name itself. Be as specific as possible with the Kill command.
folderName = "\\Server Name\Share Name\Some Folder\Old Files\"
On Error Resume Next
Kill folderName & "*.*"
On Error GoTo 0
To delete a specific file type, replace the second "*" wildcard with the file extension of the files you want to delete:
On Error Resume Next
Kill folderName & "*.xlsx"
On Error GoTo 0
Be careful with the Kill function as you can inadvertently delete valuable files. Make sure you specify the folder from which you want to delete files. And it's best to specify the file type or the file name itself. Be as specific as possible with the Kill command.
VBA Functions for working with Pervasive SQL (PSQL)
The following function will set up your connection to a Pervasive SQL database. You will need to set a reference to the Microsoft Active X Data Objects library. This function creates a DSN-less connection that will allow you to execute pass through queries using raw SQL. Pass through queries require more knowledge of SQL than using linked tables and the Access query builder. But linked tables can be a hassle to deal with and create numerous maintenance headaches. And pass-through queries are more versatile and run more efficiently than linked table queries.
The next function is for SQL SELECT queries. You'll use the previous function to set up the connection and pass it as the conn argument to the function. The function returns and ADODB record set. Remember to close the connection when you are done with it (conn.Close).
Dim conn As New ADODB.Connection
Set conn = psqlconn(dbName)
dim strSQL as String
strSQL = "SELECT * FROM SomeTable WHERE id = '" & varID & "'"
Public Function psqlQuery(conn As ADODB.Connection, strSQL As String) As ADODB.Recordset
Dim rs As New ADODB.Recordset
Dim cmd As New ADODB.Command
Set cmd.ActiveConnection = conn
cmd.CommandTimeout = 120 ' Keep queries from timing out after the default of 30 seconds
cmd.CommandText = strSQL
cmd.CommandType = adCmdText
Set rs = cmd.Execute
Set psqlQuery = rs
End Function
The next function is for Insert, Update, and Delete queries.
Public Function psqlNonQuery(conn As ADODB.Connection, strSQL As String) As Boolean
Dim cmd As New ADODB.Command
Set cmd.ActiveConnection = conn
cmd.CommandTimeout = 120 ' Keep queries from timing out after the default of 30 seconds
cmd.CommandText = strSQL
cmd.CommandType = adCmdText
cmd.Execute
psqlNonQuery = True
End Function
Public Function psqlConn(dbName as String) As ADODB.Connection
Dim conn As New ADODB.Connection
Dim strConn As String
strConn = "Driver={Pervasive ODBC Client Interface}; ServerName=SomeServer.1583;ServerDSN=" & dbName & "; UID=Uname; PWD=Pass; ArrayFetchOn=1; ArrayBufferSize=8; TransportHint=TCP:SPX;"
conn.Open strConn
Set psqlConn = conn
End Function
The next function is for SQL SELECT queries. You'll use the previous function to set up the connection and pass it as the conn argument to the function. The function returns and ADODB record set. Remember to close the connection when you are done with it (conn.Close).
Dim conn As New ADODB.Connection
Set conn = psqlconn(dbName)
dim strSQL as String
strSQL = "SELECT * FROM SomeTable WHERE id = '" & varID & "'"
Public Function psqlQuery(conn As ADODB.Connection, strSQL As String) As ADODB.Recordset
Dim rs As New ADODB.Recordset
Dim cmd As New ADODB.Command
Set cmd.ActiveConnection = conn
cmd.CommandTimeout = 120 ' Keep queries from timing out after the default of 30 seconds
cmd.CommandText = strSQL
cmd.CommandType = adCmdText
Set rs = cmd.Execute
Set psqlQuery = rs
End Function
The next function is for Insert, Update, and Delete queries.
Public Function psqlNonQuery(conn As ADODB.Connection, strSQL As String) As Boolean
Dim cmd As New ADODB.Command
Set cmd.ActiveConnection = conn
cmd.CommandTimeout = 120 ' Keep queries from timing out after the default of 30 seconds
cmd.CommandText = strSQL
cmd.CommandType = adCmdText
cmd.Execute
psqlNonQuery = True
End Function
Subscribe to:
Posts (Atom)