I am trying to add a calendar appointment from Access 2010 to an Outlook public calendar. I have found several ways to do this, but can't seem to get it to work with my code. One thing that may be the problem is that I don't understand what the code is doing when it's setting up the folder to save to. Here is my code that save to my Outlook calendar. How do I get it to save to a public Outlook calendar called janettest?
Private Sub Command60_Click()
' Exit the procedure if appointment has been added to Outlook.
If Me.chkAddedToOutlook = True Then
MsgBox "This appointment has already added to Microsoft Outlook.", vbCritical
Exit Sub
Else
' Use late binding to avoid the "Reference" issue
Dim olApp As Object 'Outlook.Application
Dim olAppt As Object 'olAppointmentItem
Dim dteTempEnd As Date
Dim dteStartDate As Date
Dim dteEndDate As Date
If isAppThere("Outlook.Application") = False Then
' Outlook is not open, create a new instance
Set olApp = CreateObject("Outlook.Application")
Else
' Outlook is already open--use this method
Set olApp = GetObject(, "Outlook.Application")
End If
Set olAppt = olApp.CreateItem(1) ' 1 = olAppointmentItem
With olAppt
If Nz(Me.AllDay_YesNo) = True Then
.Alldayevent = True
' Get the Start and the End Dates
dteStartDate = CDate(FormatDateTime(Me.TxtBeginDate, vbShortDate)) ' Begining Date
dteTempEnd = CDate(FormatDateTime(Me.txtEndDate, vbShortDate)) ' End Date
' Add one day to dteEndDate so Outlook will set the number of days correctly
dteEndDate = DateSerial(Year(dteTempEnd + 1), Month(dteTempEnd + 1), Day(dteTempEnd + 1))
.Start = dteStartDate
.End = dteEndDate
Else
.Alldayevent = False
If (Me.TxtBeginDate = Me.txtEndDate) Then
' Set the Start Property Value
.Start = CDate(FormatDateTime(Me.TxtBeginDate, vbShortDate) _
& " " & FormatDateTime(Me.txtStartTime, vbShortTime))
' Set the End Property Value
.End = CDate(FormatDateTime(Me.txtEndDate, vbShortDate) _
& " " & FormatDateTime(Me.txtEndTime, vbShortTime))
Else
' Get the Start and the End Dates
dteStartDate = CDate(FormatDateTime(Me.TxtBeginDate, vbShortDate))
dteEndDate = CDate(FormatDateTime(Me.txtEndDate, vbShortDate))
' Add one day to dteEndDate so Outlook will set the number of days correctly
.Start = dteStartDate
.End = dteEndDate + 1
End If
End If
If Len(Me.Employee & vbNullString) > 0 Then
Dim vname, vname2, vdesc As String
vname = DLookup("FirstName", "tblEmployees", "EmployeeID = " & Me.Employee)
vname2 = DLookup("LastName", "tblEmployees", "EmployeeID = " & Me.Employee)
vdesc = DLookup("Description", "tblCodesWork", "WorkCodeID = " & Me.WorkCode)
.Subject = vname & " " & vname2 & " - " & vdesc
End If
' Save the Appointment Item Properties
.Save
End With
' Set chkAddedToOutlook to checked
Me.chkAddedToOutlook = True
' Inform the user
MsgBox "New Outlook Appointment Has Been Added!", vbInformation
End If
ExitHere:
' Release Memory
Set olAppt = Nothing
Set olApp = Nothing
Exit Sub
ErrHandle:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description _
& vbCrLf & "In procedure btnAddApptToOutlook_Click in Module Module1"
Resume ExitHere
End Sub
I found a site that explains this to me. It's:
http://blogs.technet.com/b/heyscriptingguy/archive/2006/08/03/how-can-i-get-access-to-a-mail-folder-that-isn-t-a-subfolder-of-my-outlook-inbox.aspx
Related
This is pure VB6 SP3 - 8169 (Professional)
Windows 8.1
Version 6.3.9600
Toshiba Satellite S75t-A
Intel Core i7-4700MQ
Running the code throws the error shown in the uploaded dialogue.
Public Sub DBTrans()
Dim OldNum As Integer, NewNum As Integer
Dim New_CDBS, New_WRS, Old_CDBS, Old_WRS
Dim Resp, Rec As Integer
Dim i As Integer
Dim Txt0, Txt1, Txt2, Txt3, Txt5, Txt6
' Open the Database you are getting records 'FROM'
Set Old_CDBS = OpenDatabase(SourceDB, True)
Set Old_WRS = Old_CDBS.OpenRecordset("Passwords", dbOpenDynaset)
' Open the DataBase you are sending Records 'TO'
Set New_CDBS = OpenDatabase(DestinationDB, True)
Set New_WRS = CDBS.OpenRecordset("Passwords", dbOpenDynaset)
On Error GoTo ErrRes
Old_WRS.MoveFirst ' Initialize Source Database
Old_WRS.MoveLast
Old_WRS.MoveFirst
i = 1
Do Until Old_WRS.EOF = True 'Cycle through all Records in the Source Database in this 'DO' Loop
With New_WRS
' This was a test workaround effort
' Txt0 = Old_WRS.Fields(0)
' Txt1 = Old_WRS.Fields(1)
' Txt2 = Old_WRS.Fields(2)
' Txt3 = Old_WRS.Fields(3)
' Txt4 = Old_WRS.Fields(4) ' OR Rec_Num OR i
' Txt5 = Old_WRS.Fields(5)
' Txt6 = Old_WRS.Fields(6)
.AddNew ' Add A new Record to the Destination Database
.Fields(0).Value = Old_WRS.Fields(0) '= Txt0 ' Location
.Fields(1).Value = Old_WRS.Fields(1) '= Txt1 ' Logon
.Fields(2).Value = Old_WRS.Fields(2) '= Txt2 ' Password
.Fields(3).Value = Old_WRS.Fields(3) '= Txt3 ' Notes - AllowZeroLength Field
.Fields(5).Value = Old_WRS.Fields(5) '= Txt5 ' Format(Txt5, "mm/dd/yyyy")
.Fields(6).Value = Old_WRS.Fields(6) '= Txt6 ' Name
.Fields(4).Value = Old_WRS.Fields(4) ' New_Index 'OR' Rec_Num
' i = i + 1 ' Next index OR Rec_Num
.Update
.MoveFirst
.MoveLast
End With
Old_WRS.MoveNext ' Move to next Source Database Record
Loop ' Start Next data Transaction.
' Old_WRS.RecordCount is complete
' now Verify transfer with simple RecordSet.Count comparison
OldNum = Old_WRS.RecordCount
NewNum = New_WRS.RecordCount
Old_WRS.Close
Old_CDBS.Close
New_WRS.Close
Old_CDBS.Close
If NewNum = OldNum Then
MsgBox ("Transfer complete: Old DB = " & OldNum & "Records" & vbCr & "New DB has " & NewNum & "Records."), vbOKOnly
Else
MsgBox ("Something went wrong: Old DB = " & OldNum & "Records" & vbCr & "New DB has " & NewNum & " Records."), vbOKOnly
End If
ErrRes:
MsgBox "The Following Error Occurred:" & vbCr & vbCr & Err.Description & vbCr & "Aborting Edit Operation", vbOKOnly, "Error Alert"
Form1.Visible = True
Form1.Enabled = True
Unload Form4
End Sub
I am trying to remove or hide the 4 commandbuttons when exporting to PDF. The way I do it works for the first time exporting but if I export the same file again, I'll get an error referring to this line: Me.CommandButton3.Select even though all buttons are back. Is there a better way of hiding without having to delete them? I dont have printobject under properties as suggested on the internet. I should add, I still have other macros like a publish_date I do not wanna remove.
Also, I realized those commandbuttons arent saved as shapes, so trying to hide shapes didnt work either. But what about linking them to shapes and making the other shapes go into the fore and background when saving to PDF? would that work?!
Another idea was perhaps something like this:
Dim s As Shape
For Each s In ActiveDocument.Shapes
If s.Type = msoFormControl Then
If s.Type = wdButtonControl Then
s.Delete
End If
End If
Next s
It isnt working and I need the buttons back after exporting. Below my code with deleting the buttons, getting them back, but also getting an error with commandbutton 3 not working anymore, which is saving the file as .docm:
Private Sub CommandButton1_Click()
Const FilePath As String = "//SRVDC\Arbeitsordner\Intern\Meetings\Finale Versionen\"
Const OrigFileName As String = "20210910_Besprechungsnotizen_00_"
Dim Title As String: Title = "Besprechungsnotizen"
Dim newTitle As String
Dim MyDate As String: MyDate = Format(Date, "YYYYMMDD")
Dim User As String
Dim Version As String
If Split(ActiveDocument.Name, ".")(0) = OrigFileName Then
'file has not been resaved
Else
'file has been saved before so extract data from filename
Dim nameElements As Variant
nameElements = Split(Split(ActiveDocument.Name, ".")(0), "_")
User = nameElements(UBound(nameElements))
Version = nameElements(UBound(nameElements) - 1)
Title = nameElements(UBound(nameElements) - 3)
End If
If User = "" Then
User = InputBox("Wer erstellt? (Name in Firmenkurzform)")
newTitle = MsgBox("Anderer Titel?", vbQuestion + vbYesNo + vbDefaultButton2, "Titel")
If newTitle = vbYes Then
Title = InputBox("Wie soll der Titel sein?")
Else
End If
Version = "0"
Else
newVersion = MsgBox("Neue Version?", vbQuestion + vbYesNo + vbDefaultButton2, "Neue Version")
If newVersion = vbYes Then
Dim currentUser As String
currentUser = InputBox("Wer bearbeitet? (Name in Firmenkurzform)")
If currentUser = User Then
Else
User = User & currentUser
End If
Version = Format$(Version + 1)
Else
Version = Format$(Version)
End If
End If
Me.CommandButton1.Select
Selection.Delete
Me.CommandButton2.Select
Selection.Delete
Me.CommandButton3.Select
Selection.Delete
Me.Refresh.Select
Selection.Delete
ActiveDocument.ExportAsFixedFormat OutputFileName:=FilePath & _
MyDate & "_" & Title & "_i_0" & Version & "_" & User & ".pdf", _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, _
IncludeDocProps:=True, _
CreateBookmarks:=wdExportCreateWordBookmarks, _
BitmapMissingFonts:=True
ActiveDocument.Undo
ActiveDocument.Undo
ActiveDocument.Undo
ActiveDocument.Undo
ActiveDocument.Undo
End Sub
Ok I found a solution that works with a few tricks. So I added 4 rectangle shapes and I only wanna make 3 disappear while saving as PDF. It works when I wrap 3 of those shapes behind the text (or buttons) and add
With ActiveDocument
.Shapes(1).WrapFormat.Type = wdWrapFront
ActiveDocument.ExportAsFixedFormat OutputFileName:=FilePath & ...
...
.Shapes(1).WrapFormat.Type = wdWrapBehind
End With
Somehow it does put those 3 in front of the text and only puts those three behind the text again and leaving the 4th rectangle permanent in front of another text. Just as I want it. Below my entire code:
Private Sub CommandButton1_Click()
Const FilePath As String = "//SRVDC\Arbeitsordner\Intern\Meetings\Finale
Versionen\"
Const OrigFileName As String = "20210910_Besprechungsnotizen_00_"
Dim Title As String: Title = "Besprechungsnotizen"
Dim newTitle As String
Dim MyDate As String: MyDate = Format(Date, "YYYYMMDD")
Dim User As String
Dim Version As String
If Split(ActiveDocument.Name, ".")(0) = OrigFileName Then
'file has not been resaved
Else
'file has been saved before so extract data from filename
Dim nameElements As Variant
nameElements = Split(Split(ActiveDocument.Name, ".")(0), "_")
User = nameElements(UBound(nameElements))
Version = nameElements(UBound(nameElements) - 1)
Title = nameElements(UBound(nameElements) - 3)
End If
If User = "" Then
User = InputBox("Wer erstellt? (Name in Firmenkurzform)")
newTitle = MsgBox("Anderer Titel?", vbQuestion + vbYesNo + vbDefaultButton2, "Titel")
If newTitle = vbYes Then
Title = InputBox("Wie soll der Titel sein?")
Else
End If
Version = "0"
Else
newVersion = MsgBox("Neue Version?", vbQuestion + vbYesNo + vbDefaultButton2, "Neue Version")
If newVersion = vbYes Then
Dim currentUser As String
currentUser = InputBox("Wer bearbeitet? (Name in Firmenkurzform)")
If currentUser = User Then
Else
User = User & currentUser
End If
Version = Format$(Version + 1)
Else
Version = Format$(Version)
End If
End If
With ActiveDocument
.Shapes(1).WrapFormat.Type = wdWrapFront
ActiveDocument.ExportAsFixedFormat OutputFileName:=FilePath & _
MyDate & "_" & Title & "_i_0" & Version & "_" & User & ".pdf", _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, _
IncludeDocProps:=True, _
CreateBookmarks:=wdExportCreateWordBookmarks, _
BitmapMissingFonts:=True
.Shapes(1).WrapFormat.Type = wdWrapBehind
End With
End Sub
I have an Access database to report on event statistics gathered from a mainframe system. The mainframe scheduler (ZEKE) doesn't have robust reporting features, so I export daily event data to report on.
A master listing from a separate source (a static list that will not change on a regular basis) lists the individual applications, including the application code (which is the naming standard for production runs) and the name of the programmer, coordinator, manager, business unit, etc. for that application.
The user can search by any field, application code, programmer, coordinator, etc.
Choose the production center to search in (there are 5) or default to all, and choose all dates, a single date, or a date range.
The query takes the search parameters and starting with either the application code, or the person, searches the table for applications and copies records to a temp table for reporting.
For example, to see how many failures the application coordinator John Doe had for the past week for all of the applications he is responsible for, the query would move all application records listing John Doe as the coordinator to the temp table.
From there, it moves through the temp table for each application and searches the event data for events under that application code which meet the criteria entered for date, production center and event type (success, failure or both).
This is moved to a temp table for the final report.
The table for event data is currently 2.5 million lines (this is 15 days worth of data) and is growing daily.
I put the back end onto a newly created NAS drive on our network.
A report that took two minutes when the back end and front end were on the same machine now takes 29 minutes.
Any suggestions to streamline the queries over a network?
Code which is run from the report criteria selection form and runs the report.
'this macro will generate a report based on multiple input criteria.
'this report allows the user to slect:
' date range, single date or all dates
' type of events: Abends, Successes or both
' centers to pull data from: OCC,QCC,BCC,ITS,DAIN, or ALL centers
' The type of data to report on: App code, App Coordinator, Custodian, L3, L4 or L5
'Once the user has selected all of the required data and fields, the report will be generated
'based on the selection criteria.
'we begin by defining the active database as the currently open database
Dim db As DAO.Database
Set db = DBEngine(0)(0)
On Error GoTo ErrorHandler
'Now we designate the variables which will be used in this macro
Dim strSQ1 As String
Dim strSQ2 As String
Dim strSQ3 As String
Dim strSQ4 As String
Dim appl As String
Dim evstatus As String
Dim appletype As String
Dim fullapp As String
Dim length As Long
Dim iipmname As String
Dim iipmcoor As String
Dim fullappnm As String
Dim fullappcoor As String
Dim kinddate As String
Dim coor As String
Dim cust As String
Dim appL3 As String
Dim appL4 As String
Dim appL5 As String
Dim ctrOCC As String
Dim ctrMTL As String
Dim ctrBCC As String
Dim ctrITS As String
Dim ctrDAIN As String
'We will start by setting some default values
'We will ste the default values for center selection.
'We start by searching for terms we know are not there, then change them to
'valid search terms if the center is selected.
ctrOCC = "notOCC"
ctrMTL = "notMTL"
ctrBCC = "notBCC"
ctrITS = "notITS"
ctrDAIN = "notUSWM"
fullapp = "*"
'First we determine which event types the user wants to look for
state = Me![opt-status].Value
If state = 1 Then
evstatus = " [ev-status] = 'AEOJ'"
ElseIf state = 2 Then
evstatus = " [ev-status] = 'EOJ'"
ElseIf state = 3 Then
evstatus = " ([ev-status] = 'EOJ' OR [ev-status] = 'AEOJ')"
End If
'MsgBox "Event status pulled is:.. " & evstatus & "."
' Next up we will configure the date parameters based on the user input
If [grp-datesel] = 1 Then
Sdte = "1"
Edte = "9999999"
kinddate = "[ev-date] >= " & Sdte & " AND [ev-date] <= " & Edte & " "
End If
If [grp-datesel] = 2 Then
'error handling
If IsNull(Me.[sel-onedate]) Then
MsgBox "You have not entered a date to search....please try again."
Me.[sel-onedate] = Null
Me.[sel-onedate].SetFocus
Exit Sub
End If
'end of error handling
Dim currdte As Date
currdte = Me![sel-onedate].Value
currjul = Format(currdte, "yyyyy")
daycurr = CDbl(currjul)
Sdte = daycurr
Edte = daycurr
kinddate = "[ev-date] >= " & Sdte & " AND [ev-date] <= " & Edte & " "
End If
If [grp-datesel] = 3 Then
'error handling
If IsNull(Me.[sel-Sdate]) Or IsNull(Me.[sel-Edate]) Then
MsgBox "You Must enter a start and end date for the search....please try again."
Me.[sel-Sdate] = Null
Me.[sel-Edate] = Null
Me.[sel-Sdate].SetFocus
Exit Sub
End If
'end of error handling
Dim startdte As Date
Dim enddte As Date
startdte = Me.[sel-Sdate].Value
enddte = Me.[sel-Edate].Value
startjul = Format(startdte, "yyyyy")
endjul = Format(enddte, "yyyyy")
Sday = CDbl(startjul)
Eday = CDbl(endjul)
Sdte = Sday
Edte = Eday
'MsgBox "start date is " & Sdte & " and end date is " & Edte & "."
'check that dates are in proper chronological order
If Sdte > Edte Then
MsgBox "The start Date you entered is after the end date....please try again."
Me.[sel-Sdate] = Null
Me.[sel-Edate] = Null
Me.[sel-Sdate].SetFocus
Exit Sub
End If
'keep going if it's all good
kinddate = "[ev-date] >= " & Sdte & " AND [ev-date] <= " & Edte & " "
End If
MsgBox "Date used is:.. " & kinddate & "."
'Now lets look at center selection
If [chk-allctr].Value = True Then
ctrOCC = "OCC"
ctrMTL = "MTL"
ctrBCC = "BCC"
ctrITS = "ITS"
ctrDAIN = "USWM"
End If
If [chk-OCC].Value = True Then
ctrOCC = "OCC"
End If
If [chk-MTL].Value = True Then
ctrMTL = "MTL"
End If
If [chk-BCC].Value = True Then
ctrBCC = "BCC"
End If
If [chk-RTF].Value = True Then
ctrITS = "ITS"
End If
If [chk-DAIN].Value = True Then
ctrDAIN = "DAIN"
End If
'Error handling if no center is selected
If [chk-OCC].Value = Flase Then
If [chk-MTL].Value = Flase Then
If [chk-BCC].Value = Flase Then
If [chk-RTF].Value = Flase Then
If [chk-DAIN].Value = Flase Then
MsgBox "You have not selected a center to search search....please try again."
Me.[chk-allctr].SetFocus
Exit Sub
End If
End If
End If
End If
End If
'end of error handling
'MsgBox "centers used are: Chr(10) " & ctrOCC & " Chr(10) " & ctrBCC & " Chr(10) " & ctrMTL & " Chr(10) " & ctrITS & " Chr(10) " & ctrDAIN & " For this run"
'All good so far, now we will parse the application code if an
'application code report is selected
appl = "*"
If [opt-criteria].Value = 1 Then
'error handling
If IsNull(Me.[sel-appcode]) Then
MsgBox "You have not entered an application code to search....please try again."
Me.[sel-appcode] = Null
Me.[sel-appcode].SetFocus
Exit Sub
End If
'end of error handling
End If
If [opt-criteria].Value = 1 Then
appl = Me![sel-appcode].Value
End If
'trust = "no"
'If Mid(appl, 3, 2) = "RT" Then trust = "yes"
'length = Len(appl)
'If length = 2 Then appltype = "short"
'If length = 3 Then appltype = "long"
'If appltype = "short" Then fullapp = "" & appl & "00"
'If appltype = "long" Then fullapp = "" & appl & "0"
'If trust = "yes" Then fullapp = appl
'End If
fullapp = appl
'MsgBox "App to use is: " & appl & " fullapp code is " & fullapp & "."
'Now we set values if names are used
coor = "*"
cust = "*"
appL3 = "*"
appL4 = "*"
appL5 = "*"
If [opt-criteria].Value = 2 Then
'error handling
If IsNull(Me.[sel-coor]) Then
MsgBox "You have not entered a Coordinator to search....please try again."
Me.[sel-coor] = Null
Me.[sel-coor].SetFocus
Exit Sub
End If
'end of error handling
coor = Me![sel-coor].Value
'MsgBox "Coordinator report selected for: " & coor & "."
End If
If [opt-criteria].Value = 3 Then
'error handling
If IsNull(Me.[sel-custodian]) Then
MsgBox "You have not entered a Custodian to search....please try again."
Me.[sel-custodian] = Null
Me.[sel-custodian].SetFocus
Exit Sub
End If
'end of error handling
cust = Me![sel-custodian].Value
'MsgBox "Custodian report selected for: " & cust & "."
End If
If [opt-criteria].Value = 4 Then
'error handling
If IsNull(Me.[sel-L3]) Then
MsgBox "You have not entered an L3 to search....please try again."
Me.[sel-L3] = Null
Me.[sel-L3].SetFocus
Exit Sub
End If
'end of error handling
appL3 = Me![sel-L3].Value
'MsgBox "L3 report selected for: " & appL3 & "."
End If
If [opt-criteria].Value = 5 Then
'error handling
If IsNull(Me.[sel-L4]) Then
MsgBox "You have not entered an L4 to search....please try again."
Me.[sel-L4] = Null
Me.[sel-L4].SetFocus
Exit Sub
End If
'end of error handling
appL4 = Me![sel-L4].Value
'MsgBox "L4 report selected for: " & appL4 & "."
End If
If [opt-criteria].Value = 6 Then
'error handling
If IsNull(Me.[sel-L5]) Then
MsgBox "You have not entered an L5 to search....please try again."
Me.[sel-L5] = Null
Me.[sel-L5].SetFocus
Exit Sub
End If
'end of error handling
appL5 = Me![sel-L5].Value
'MsgBox "L5 report selected for: " & appL5 & "."
End If
'Most of these reports take a while to build with this macro, so to make sure the user
'knows that the macro is still working, we didsplay a splash screen. It's cute and has
'hamsters, cause everyone loves hamsters.
DoCmd.OpenForm "PlsWaitFrm", acWindowNormal
[Forms]![PlsWaitFrm].Repaint
'All of out criteria values are now selected. We can move on to pulling data from the tables.
'We start by populating the IIPM table with the information that we require for applications.
strSQ1 = "DELETE * from [tbl-RPT-IIPM] "
db.Execute strSQ1
strSQ2 = "INSERT INTO [tbl-RPT-IIPM] " & _
"SELECT * FROM [tbl-IIPM] " & _
"WHERE (([AppCode] like '" & fullapp & "')" & _
"AND ([AppCoordinator] like '" & coor & "') " & _
"AND ([AppCustodian] like '" & cust & "') " & _
"AND ([L3] like '" & appL3 & "') " & _
"AND ([L4] like '" & appL4 & "') " & _
"AND ([L5] like '" & appL5 & "')) "
db.Execute strSQ2
'MsgBox "made it past the populate of rpt-iipm"
'Now we have populated the IIPM report table, it's time to populate the event report table.
'We will loop through all fields in the IIPM report table and pull information for each
'application code.
strSQ3 = "DELETE * from [tbl-EVENTREPORT] "
db.Execute strSQ3
Dim rs As DAO.Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("tbl-RPT-IIPM") 'this opens the IIPM report table just populated
'populate the table
rs.MoveLast
rs.MoveFirst
Do While Not rs.EOF
'we will execute these action against the selected record.
'first step - parse the application code to display the full application code
appl = rs![AppCode].Value
length = Len(appl)
If length = 1 Then appl = "" & appl & "00"
rptdelin = Mid(appl, 3, 1)
rptcode = Mid(appl, 1, 3)
If rptdelin = "0" Then rptcode = Mid(appl, 1, 2)
If rptdelin = "R" Then rptcode = "RT" & Mid(appl, 1, 2) & ""
'MsgBox "searching for: " & rptcode & "."
applist = applist & "," & appl
strSQ4 = "INSERT INTO [tbl-EVENTREPORT] " & _
"SELECT * FROM [tbl-EVENT DATA] " & _
"WHERE (([ev-jobname] LIKE '?" & rptcode & "*') " & _
"AND (([ev-ctr] = '" & ctrOCC & "')" & _
"OR ([ev-ctr] = '" & ctrMTL & "')" & _
"OR ([ev-ctr] = '" & ctrBCC & "')" & _
"OR ([ev-ctr] = '" & ctrITS & "')" & _
"OR ([ev-ctr] = '" & ctrDAIN & "'))" & _
"AND (" & kinddate & ") " & _
"AND " & evstatus & ")"
db.Execute strSQ4
'now we're done with this report, we move on to the next
rs.MoveNext 'press Ctrl+G to see debuG window beneath
Loop
'END OF LOOPING CODE
'MsgBox "made it past the looping"
'Now we have completed populating the table that the report will be based on.
'Next step is to gather master statistics to produce abend and success percentages.
totfail = DCount("[ev-status]", "tbl-EVENTREPORT", "[ev-status] = 'AEOJ'")
totsucc = DCount("[ev-status]", "tbl-EVENTREPORT", "[ev-status] = 'EOJ'")
Dim allabend As Long
Dim allsucc As Long
allabend = DCount("[ev-status]", "[tbl-EVENT DATA]", "[ev-status] = 'AEOJ' AND ([ev-date] >= " & Sdte & " AND [ev-date] <= " & Edte & ")")
allsucc = DCount("[ev-status]", "[tbl-EVENT DATA]", "[ev-status] = 'EOJ' AND ([ev-date] >= " & Sdte & " AND [ev-date] <= " & Edte & ")")
Dim pctabend As Long
Dim pctsucc As Long
pctabend = (totfail / allabend) * 100
pctsucc = (totsucc / allsucc) * 100
'Now we will generate the reports for display based on what type of report was selected
'by the user in the initial form.
'Before we open the report, we will close the splash screen
DoCmd.Close acForm, "PlsWaitFrm", acSaveNo
'Now we open the report
If [opt-criteria].Value = 1 Then
fullappnm = DLookup("AppName", "tbl-RPT-IIPM", "AppCode = '" & fullapp & "' ")
fullappcoor = DLookup("AppCoordinator", "tbl-RPT-IIPM", "AppCode = '" & fullapp & "' ")
DoCmd.OpenReport "rpt-APPLREPORT", acViewReport
[Reports]![rpt-APPLREPORT]![rpt-appcode].Value = fullapp
[Reports]![rpt-APPLREPORT]![rpt-appname].Value = fullappnm
[Reports]![rpt-APPLREPORT]![rpt-appcoor].Value = fullappcoor
[Reports]![rpt-APPLREPORT]![rpt-abendtot].Value = totfail
[Reports]![rpt-APPLREPORT]![rpt-succtot].Value = totsucc
[Reports]![rpt-APPLREPORT]![rpt-abdpct].Value = pctabend
[Reports]![rpt-APPLREPORT]![rpt-succpct].Value = pctsucc
End If
If [opt-criteria].Value = 2 Then
DoCmd.OpenReport "rpt-COORREPORT", acViewReport
[Reports]![rpt-COORREPORT]![rpt-appcode].Value = applist
[Reports]![rpt-COORREPORT]![rpt-appcoor].Value = coor
[Reports]![rpt-COORREPORT]![rpt-abendtot].Value = totfail
[Reports]![rpt-COORREPORT]![rpt-succtot].Value = totsucc
[Reports]![rpt-COORREPORT]![rpt-abdpct].Value = pctabend
[Reports]![rpt-COORREPORT]![rpt-succpct].Value = pctsucc
End If
If [opt-criteria].Value = 3 Then
DoCmd.OpenReport "rpt-CUSTREPORT", acViewReport
[Reports]![rpt-CUSTREPORT]![rpt-appcode].Value = applist
[Reports]![rpt-CUSTREPORT]![rpt-appcoor].Value = cust
[Reports]![rpt-CUSTREPORT]![rpt-abendtot].Value = totfail
[Reports]![rpt-CUSTREPORT]![rpt-succtot].Value = totsucc
[Reports]![rpt-CUSTREPORT]![rpt-abdpct].Value = pctabend
[Reports]![rpt-CUSTREPORT]![rpt-succpct].Value = pctsucc
End If
If [opt-criteria].Value = 4 Then
DoCmd.OpenReport "rpt-L3REPORT", acViewReport
[Reports]![rpt-L3REPORT]![rpt-appcode].Value = applist
[Reports]![rpt-L3REPORT]![rpt-appcoor].Value = appL3
[Reports]![rpt-L3REPORT]![rpt-abendtot].Value = totfail
[Reports]![rpt-L3REPORT]![rpt-succtot].Value = totsucc
[Reports]![rpt-L3REPORT]![rpt-abdpct].Value = pctabend
[Reports]![rpt-L3REPORT]![rpt-succpct].Value = pctsucc
End If
If [opt-criteria].Value = 5 Then
DoCmd.OpenReport "rpt-L4REPORT", acViewReport
[Reports]![rpt-L4REPORT]![rpt-appcode].Value = applist
[Reports]![rpt-L4REPORT]![rpt-appcoor].Value = appL4
[Reports]![rpt-L4REPORT]![rpt-abendtot].Value = totfail
[Reports]![rpt-L4REPORT]![rpt-succtot].Value = totsucc
[Reports]![rpt-L4REPORT]![rpt-abdpct].Value = pctabend
[Reports]![rpt-L4REPORT]![rpt-succpct].Value = pctsucc
End If
If [opt-criteria].Value = 6 Then
DoCmd.OpenReport "rpt-L5REPORT", acViewReport
[Reports]![rpt-L5REPORT]![rpt-appcode].Value = applist
[Reports]![rpt-L5REPORT]![rpt-appcoor].Value = appL5
[Reports]![rpt-L5REPORT]![rpt-abendtot].Value = totfail
[Reports]![rpt-L5REPORT]![rpt-succtot].Value = totsucc
[Reports]![rpt-L5REPORT]![rpt-abdpct].Value = pctabend
[Reports]![rpt-L5REPORT]![rpt-succpct].Value = pctsucc
End If
ErrorHandler:
If Err.Number = 7874 Then
Resume Next 'Tried to delete a non-existing table, resume
End If
End Sub
'''
Firstly, you need to work out where the bottlenecks are, so I would suggest putting some Debug.Print Now statements throughout the code to give you an idea of what is causing the issue.
I would guess that two of the processes that take most of the time are the DELETE/INSERT statements that you are doing.
I would suggest that rather than doing this, you look at normalizing your database, and then creating a query that provides the information that you need.
Also, by running the report directly from a query rather than a temporary table means that you don't have to worry about the deletes/inserts creating database bloat.
If you really insist on keeping this process, then consider deleting the table [tbl-RPT-IIPM] and then recreating it, rather than deleting the records. And consider removing the indexes before the insert, and then adding them back afterwards, as indexes splow down inserts, but obviously speed up searches and joins.
Also, when you are inserting data into [tbl-RPT-IIPM], you are using ([L3] like '" & appL3 & "'), which is the same as ([L3]='" & appL3 & "'), but slower.
When you are inserting data into [tbl-EVENTREPORT], you are doing it when looping through a recordset - it may be faster to use an INSERT SQL statement.
Regards,
OK, with some more information, some more answers that may (or may not!!) help. Again, you will need to run timing tests to see which works best for you.
Try adding a "Yes/No" field to the table [tbl-EVENT DATA]. You can then use an UPDATE statement to indicate which fields to include in the report, rather than using the slow INSERT query.
Another thing to try would be to replace the INSERT statement with several, each using a different value for [ev-ctr]. Or else rather than using OR try using IN:
strSQ4 = "INSERT INTO [tbl-EVENTREPORT] " & _
"SELECT * FROM [tbl-EVENT DATA] " & _
"WHERE [ev-jobname] LIKE '?" & rptcode & "*' " & _
"AND [ev-ctr] IN('" & ctrOCC & "','" & ctrMTL & "','" & ctrBCC & "','" & ctrITS & "','" & ctrDAIN & "')" & _
"AND " & kinddate & _
"AND " & evstatus
Also, I notice that kinddate is set to effectively include all dates in one instance, and that evstatus is set to include both "EOJ" and "AEOJ" in one instance. Rather than including these fields as criteria in these cases, you may wish to not include them at all:
If state = 1 Then
evstatus = " AND [ev-status] = 'AEOJ'"
ElseIf state = 2 Then
evstatus = " AND [ev-status] = 'EOJ'"
ElseIf state = 3 Then
evstatus = " "
End If
And then you would rewrite " AND " & evstatus to & evstatus in the SQL statement.
A final thing to look at is to actually run the INSERT directly in the backend, rather than operating on linked tables in the frontend, as Access will be dragging vast amounts of data across the network and then sending it back. As a basic guide, something like this:
Sub sUpdateQuery()
Dim objAccess As New Access.Application
objAccess.OpenCurrentDatabase "J:\downloads\test.accdb"
objAccess.DoCmd.RunSQL "UPDATE test2 SET Field1=UCASE(Field1);"
objAccess.CloseCurrentDatabase
Set objAccess = Nothing
End Sub
Regards,
Applecore, Firstly, let me thank you for your insights. Unfortunately due to the nature of the way the data is processed, some of them I'm not sure I can implement. I have used debug.print statements to get a better idea of the timing.
You are correct, the INSERT statement is causing me the most problems, and only the second one. The deletes fly through almost instantly, no issues there. It's the second insert from the event data that is slowing it down.
I have been thinking about this since inception of how to nromalize more efficiently and create better relationships, but I'm stymied. My issue is, the data between the event table and the event table are related "in the world" but in no clear way in terms of data. There is no way to determine the relationship without a complex calculation. For example, the unique part of the application data is the application code. They are always unique. A single Application coordinator can have dozens of codes assigned to them, as can custodians, L3,L4, etc. Each event is related to an application, however, there is no specific field that is exported that tells the application code, it is obtained by parsing the event name (And yes, that is as archaic as it sounds). The event naming standards are standard mainframe 8 character names: .
For example PGRD1234 - Production job, GRD application, 1234 as the designator. So to determine what application the job is related to, I take the application code, and select LIKE with wildcards. It's not 100% accurate I am well aware, but to use wildcards, I seem to be stuck using LIKE. I haven't been able to make '=' work with wildcards. Can you?
You also mentioned "When you are inserting data into [tbl-EVENTREPORT], you are doing it when looping through a recordset - it may be faster to use an INSERT SQL statement." which I'm not sure what you are saying.. My apologies. I don't think I am understanding it. I think that is what I am doing now. I use the IIPM table to obtain the listing of the application codes I need to pull, then loop through that recordset to pull all of the event data for only those applications. As there is no direct correlation between the data, I Can't think of another way to do it.
Looking to see if there would be a way for users to update their MS Access db front end by clicking a button. The button would then trigger a batch file that would grab the file from a location on our server, and overwrite the current db on the users local PC. All done within one office, so network addresses would be all the same.
Location of file to copy: 10.0.0.0.5/Data/DB/Database.accdb
Location of file to overwrite: c:\DB\Database.accdb
Any ideas? Ideally I would love for someone to write a nice exe file that deletes the older version and installs the newer version, but can't write that kind of code.
Write a batch file to retrieve the newer version of the front end from it's source and copy it into the folder where the user's copy of the front end file lives. Add a line at the end of the batch file to launch msacess.exe with the filename of your front end program as a command line parameter.
The batch file can be located anywhere, but I recommend locating it in the folder where your application front end will reside.
Create a Windows shortcut to the batch file, which can be placed on the users' Desktop or anywhere else the user expects to launch the application.
Bonus points for dressing up the shortcut to the batch file by changing the icon: Right-click|Properties|Change icon... button.
A nice article on the topic can be found here:
Deploy and update a Microsoft Access application in a Citrix environment
It uses neither a bat, nor an exe, but a VBscript:
Option Explicit
' Launch script for PPT test/development/operation.
' Version 1.3.0
' 2013-09-15
' Cactus Data. Gustav Brock
Const DESKTOP = &H10
Const LOCALAPPDATA = &H1C
Dim objFSO
Dim objAppShell
Dim objDesktopFolder
Dim objLocalAppDataFolder
Dim objLocalFolder
Dim objRemoteFolder
Dim strLocalFolder
Dim strRemoteFolder
Dim strDesktopFolder
Dim strLocalAppDataFolder
Dim strLocalAppDataDsgFolder
Dim strLocalAppDataDsgPptFolder
Dim strDsgSubfolder
Dim strPptSubfolder
Dim strPptAppSubfolder
Dim strPptNcSuffix
Dim strAppName
Dim strAppSuffix
Dim strShortcutName
Dim strAppLocalPath
Dim strAppLocalBackPath
Dim strAppRemotePath
Dim strShortcutLocalPath
Dim strShortcutRemotePath
Dim strRegPath
Dim strRegKey
Dim strRegValue
Dim booNoColour
Dim varValue
' Adjustable parameters.
strDsgSubfolder = "DSG"
strPptSubfolder = "PPT"
strPPtNcSuffix = "NC"
' ---------------------------------------------------------------------------------
' Uncomment one folder name only:
'strPptAppSubfolder = "Development"
strPptAppSubfolder = "Operations"
'strPptAppSubfolder = "Test"
' ---------------------------------
' Indicate if the script is for the normal version (0) or the no-colour version (1):
booNoColour = 0
' ---------------------------------------------------------------------------------
strRemoteFolder = "K:\_Shared\Sales Planning\Environments\" & strPptAppSubfolder
If booNoColour = 1 Then
strAppSuffix = strPptNcSuffix
Else
strAppSuffix = ""
End If
strAppName = "SalesPlanningTool" & strAppSuffix & ".accdb"
If strPptAppSubfolder = "Operations" Then
If strAppSuffix = "" Then
strShortcutName = "RunPPT.lnk"
Else
strShortcutName = "RunPPT " & strAppSuffix & ".lnk"
End If
Else
If strAppSuffix = "" Then
strShortcutName = "RunPPT " & strPptAppSubfolder & ".lnk"
Else
strShortcutName = "RunPPT " & strAppSuffix & " " & strPptAppSubfolder & ".lnk"
End If
End If
' Enable simple error handling.
On Error Resume Next
' Find user's Desktop and AppData\Local folder.
Set objAppShell = CreateObject("Shell.Application")
Set objDesktopFolder = objAppShell.Namespace(DESKTOP)
strDesktopFolder = objDesktopFolder.Self.Path
Set objLocalAppDataFolder = objAppShell.Namespace(LOCALAPPDATA)
strLocalAppDataFolder = objLocalAppDataFolder.Self.Path
' Dynamic parameters.
strLocalAppDataDsgFolder = strLocalAppDataFolder & "\" & strDsgSubfolder
strLocalAppDataDsgPptFolder = strLocalAppDataDsgFolder & "\" & strPptSubfolder
strLocalFolder = strLocalAppDataDsgPptFolder & "\" & strPptAppSubfolder
strAppLocalPath = strLocalFolder & "\" & strAppName
strShortcutLocalPath = strDesktopFolder & "\" & strShortcutName
' Permanent parameters.
strAppRemotePath = strRemoteFolder & "\" & strAppName
strShortcutRemotePath = strRemoteFolder & "\" & strShortcutName
' Create the File System Object.
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FolderExists(strRemoteFolder) Then
Call ErrorHandler("No access to " & strRemoteFolder & ".")
Else
Set objRemoteFolder = objFSO.GetFolder(strRemoteFolder)
' If local folder does not exist, create the folder.
If Not objFSO.FolderExists(strLocalFolder) Then
If Not objFSO.FolderExists(strLocalAppDataDsgFolder) Then
Set objLocalFolder = objFSO.CreateFolder(strLocalAppDataDsgFolder)
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Folder " & strLocalAppDataDsgFolder & " could not be created.")
End If
End If
If Not objFSO.FolderExists(strLocalAppDataDsgPPtFolder) Then
Set objLocalFolder = objFSO.CreateFolder(strLocalAppDataDsgPptFolder)
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Folder " & strLocalAppDataDsgPptFolder & " could not be created.")
End If
End If
If Not objFSO.FolderExists(strLocalFolder) Then
Set objLocalFolder = objFSO.CreateFolder(strLocalFolder)
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Folder " & strLocalFolder & " could not be created.")
End If
End If
End If
Set objLocalFolder = objFSO.GetFolder(strLocalFolder)
End If
If Not objFSO.FileExists(strAppRemotePath) Then
Call ErrorHandler("The application file:" & vbCrLf & strAppRemotePath & vbCrLF & "could not be found.")
Else
' Close a running PPT.
Call KillTask("PPT")
' Wait while TaskKill is running twice to close the instance(s) of PPT and PPT Background.
Call AwaitProcess("taskkill.exe")
Call KillTask("PPT Background")
' Wait while TaskKill is running twice to close the instance(s) of PPT and PPT Background.
Call AwaitProcess("taskkill.exe")
' Copy app to local folder.
If objFSO.FileExists(strAppLocalPath) Then
objFSO.DeleteFile(strAppLocalPath)
If Not Err.Number = 0 Then
Call ErrorHandler("The application file:" & vbCrLf & strAppName & vbCrLF & "can not be refreshed/updated. It may be in use.")
End If
End If
If objFSO.FileExists(strAppLocalPath) Then
Call ErrorHandler("The local application file:" & vbCrLf & strAppLocalPath & vbCrLF & "could not be replaced.")
Else
objFSO.CopyFile strAppRemotePath, strAppLocalPath
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Application could not be copied to " & strLocalFolder & ".")
End If
' Create copy for PPT Background.
strAppLocalBackPath = Replace(Replace(strAppLocalPath, ".accdb", ".accbg"), "SalesPlanningTool", "SalesPlanningToolBack")
objFSO.CopyFile strAppLocalPath, strAppLocalBackPath
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Background application could not be copied to " & strLocalFolder & ".")
End If
End If
' Copy shortcut.
objFSO.CopyFile strShortcutRemotePath, strShortcutLocalPath
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Shortcut could not be copied to your Desktop.")
End If
End If
' Write Registry entries for Access security.
strRegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Access\Security\"
strRegValue = "VBAWarnings"
strRegPath = strRegKey & strRegValue
varValue = 1
Call WriteRegistry(strRegPath, varValue,"REG_DWORD")
strRegKey = strRegKey & "Trusted Locations\LocationLocalAppData\"
strRegValue = "AllowSubfolders"
strRegPath = strRegKey & strRegValue
varValue = 1
Call WriteRegistry(strRegPath, varValue, "REG_DWORD")
strRegValue = "Date"
strRegPath = strRegKey & strRegValue
varValue = Now
varValue = FormatDateTime(varValue, vbShortDate) & " " & FormatDateTime(varValue, vbShortTime)
Call WriteRegistry(strRegPath, varValue, "REG_SZ")
strRegValue = "Description"
strRegPath = strRegKey & strRegValue
varValue = "Local AppData"
Call WriteRegistry(strRegPath, varValue, "REG_SZ")
strRegValue = "Path"
strRegPath = strRegKey & strRegValue
varValue = strLocalAppDataFolder & "\"
Call WriteRegistry(strRegPath, varValue, "REG_SZ")
' Run PPT.
If objFSO.FileExists(strAppLocalPath) Then
Call RunApp(strAppLocalPath, False)
Else
Call ErrorHandler("The local application file:" & vbCrLf & strAppLocalPath & vbCrLF & "could not be found.")
End If
Set objRemoteFolder = Nothing
Set objLocalFolder = Nothing
Set objLocalAppDataFolder = Nothing
Set objDesktopFolder = Nothing
Set objAppShell = Nothing
Set objFSO = Nothing
WScript.Quit
' Supporting subfunctions
' -----------------------
Sub RunApp(ByVal strFile, ByVal booBackground)
Dim objShell
Dim intWindowStyle
' Open as default foreground application.
intWindowStyle = 1
Set objShell = CreateObject("WScript.Shell")
objShell.Run Chr(34) & strFile & Chr(34), intWindowStyle, False
Set objShell = Nothing
End Sub
Sub KillTask(ByVal strWindowTitle)
Dim objShell
Set objShell = CreateObject("WScript.Shell")
objShell.Run "TaskKill.exe /FI ""WINDOWTITLE eq " & strWindowTitle & """", 7, False
Set objShell = Nothing
End Sub
Sub AwaitProcess(ByVal strProcess)
Dim objSvc
Dim strQuery
Dim colProcess
Dim intCount
Set objSvc = GetObject("winmgmts:root\cimv2")
strQuery = "select * from win32_process where name='" & strProcess & "'"
Do
Set colProcess = objSvc.Execquery(strQuery)
intCount = colProcess.Count
If intCount > 0 Then
WScript.Sleep 300
End If
Loop Until intCount = 0
Set colProcess = Nothing
Set objSvc = Nothing
End Sub
Sub WriteRegistry(ByVal strRegPath, ByVal varValue, ByVal strRegType)
' strRegType should be:
' "REG_SZ" for a string
' "REG_DWORD" for an integer
' "REG_BINARY" for a binary or boolean
' "REG_EXPAND_SZ" for an expandable string
Dim objShell
Set objShell = CreateObject("WScript.Shell")
Call objShell.RegWrite(strRegPath, varValue, strRegType)
Set objShell = Nothing
End Sub
Sub ErrorHandler(Byval strMessage)
Set objRemoteFolder = Nothing
Set objLocalFolder = Nothing
Set objLocalAppDataFolder = Nothing
Set objDesktopFolder = Nothing
Set objAppShell = Nothing
Set objFSO = Nothing
WScript.Echo strMessage
WScript.Quit
End Sub
You could probably convert it to PowerShell, which I would use today.
I use a vbscript for that purpose. I only update the path for the file due to be copied and then I sent an email to the users with a link to the script. The user clicks the link and the script is executed.
Copy the code below to a text file and save it as .vbs. Don't forget to set the path for the file due to be copied.
Option Explicit
Call Main()
Private Sub Main()
const folderFrom = "\\Somepath\Somefolder\" 'Folder: Must supply backslash
const fileName = "SomeFile.accdb" 'File name with extension
const overwrite = -1 'OverWrite = True
'Ask user to proceed
dim msg
msg = "The script will copy the file below to your desktop. " & vbNewLine & vbNewLine & _
String(75,"_") & vbNewLine & vbNewLine & _
"File: " & " " & " " & " " & " " & " " & " " & " '" & fileName & "' " & vbNewLine & _
"Folder: " & " " & " '" & folderFrom & "' " & vbNewLine & _
String(75,"_") & vbNewLine & vbNewLine & _
"Proceed?"
if MsgBox(msg, vbYesNo + vbQuestion, "FileCopy Confirmation") = vbNo then exit sub
on error resume next
dim filesys
set filesys = CreateObject("Scripting.FileSystemObject")
'File exists in folder?
if not filesys.FileExists(folderFrom & fileName) then
MsgBox "File not found. Task aborted. ", vbOKOnly + vbExclamation, "Attention:"
exit sub
end if
'User's desktop path
dim desktopPath
desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
'Copy file
filesys.CopyFile folderFrom & fileName, desktopPath & fileName, overwrite
'Validate file copied
if filesys.FileExists(desktopPath & fileName) then
Msgbox "File copied successfully.", vbOKOnly + vbInformation, "Success!"
else
MsgBox "File could not be copied... ", vbOKOnly + vbExclamation, "Copy Failed..."
end if
End Sub
Suggestion:
You shouldn't overwrite the existing front-end database but instead you should consider versioning e.g. v2.0, v2.1, v2.2 etc. for better tracking.
Does anyone know how I could go about finding out when a certificate for user is set to expire? I know I can get pull all of the certificates for a given user by usin the following code:
Set objUserTemplate = _
GetObject("LDAP://cn=userTemplate,OU=Management,dc=NA,dc=fabrikam,dc=com")
arrUserCertificates = objUserTemplate.GetEx("userCertificate")
But then how do I go about polling the expiration date for a given certificate? I did see this java code here: http://forums.novell.com/novell-developer-forums/dev-ldap/364977-q-retrieving-users-public-key-over-ldap.html,
X509Certificate cert = ( X509Certificate )it.next();
java.util.Date expires = cert.getNotAfter();
GregorianCalendar calNow = new GregorianCalendar();
GregorianCalendar calExp = new GregorianCalendar();
calExp.setTime( expires );
//issuerDN = cert.getIssuerDN().getName();
int daysTilExp = com.willeke.utility.DateUtils.daysPast( calExp );
long diffDays = com.willeke.utility.DateUtils.diffDayPeriods( calNow,
calExp );
if( diffDays <= 0 )
{
String mex = " Will expire in: " + diffDays + " days!";
but I'm not sure if I can use the getNotAfter method within VB, or how I would go about doing it. Does anyone have any ideas? If at all possible I would like help in doing this query in VBScript/VB.Net/VBA, etc.
I did find this VBScript code here which seems to be doing what I am trying to accomplish, but is seems pretty complex, where as the java code seemed much simpler. Is there an easier way to do this query in some flavor of VB?
From the cruto site:
On Error Resume Next
Const E_ADS_PROPERTY_NOT_FOUND = &h8000500D
Const ForWriting = 2
Const WshRunning = 0
Set objUser = GetObject _
("GC://cn=MyerKen,ou=Management,dc=NA,dc=fabrikam,dc=com")
objUser.GetInfoEx Array("userCertificate"), 0
arrUserCertificates = objUser.GetEx("userCertificate")
If Err.Number = E_ADS_PROPERTY_NOT_FOUND Then
WScript.Echo "No assigned certificates"
WScript.Quit
Else
Set objShell = CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
strPath = "."
intFileCounter = 0
For Each arrUserCertificate in arrUserCertificates
strFileName = "file" & intFileCounter
strFullName = objFSO.BuildPath(strPath, strFileName)
Set objFile = objFSO.OpenTextFile(strFullName, ForWriting, True)
For i = 1 To LenB(arrUserCertificate)
ReDim Preserve arrUserCertificatesChar(i - 1)
arrUserCertificatesChar(i-1) = _
Hex(AscB(MidB(arrUserCertificate, i, 3)))
Next
intCounter=0
For Each HexVal in arrUserCertificatesChar
intCounter=intCounter + 1
If Len(HexVal) = 1 Then
objFile.Write(0 & HexVal & " ")
Else
objFile.Write(HexVal & " ")
End If
Next
objFile.Close
Set objFile = Nothing
Set objExecCmd1 = objShell.Exec _
("certutil -decodeHex " & strFileName & " " & strFileName & ".cer")
Do While objExecCmd1.Status = WshRunning
WScript.Sleep 100
Loop
Set objExecCmd1 = Nothing
Set objExecCmd2 = objShell.Exec("certutil " & strFileName & ".cer")
Set objStdOut = objExecCmd2.StdOut
Set objExecCmd2 = Nothing
WScript.Echo VbCrLf & "Certificate " & intFileCounter + 1
While Not objStdOut.AtEndOfStream
strLine = objStdOut.ReadLine
If InStr(strLine, "Issuer:") Then
WScript.Echo Trim(strLine)
WScript.Echo vbTab & Trim(objStdOut.ReadLine)
End If
If InStr(strLine, "Subject:") Then
Wscript.Echo Trim(strLine)
WScript.Echo vbTab & Trim(objStdOut.ReadLine)
End If
If InStr(strLine, "NotAfter:") Then
strLine = Trim(strLine)
WScript.Echo "Expires:"
Wscript.Echo vbTab & Mid(strLine, 11)
End If
Wend
objFSO.DeleteFile(strFullName)
objFSO.DeleteFile(strPath & "\" & strFileName & ".cer")
intFileCounter = intFileCounter + 1
Next
End If
Update I did see that I could import the certificate into the CAPICOM object to return back the ValidToDate Property, but apparently the format inwhich it is stored in AD is of the wrong format according to this posting here: http://www.powershellcommunity.org/Forums/tabid/54/aff/4/aft/1639/afv/topic/Default.aspx
Does anyone know what format is expected from the CAPICOM import function?
Microsoft has an ActiveX control called CAPICOM which allows you to programmatically access various properties of the certificate. The MSDN CAPICOM article details these functions. The Platform SDK (linked from the Where to get it link) includes samples, documentation and the redistributable control. The samples include VBScript examples. I found the download for the Platform SDK here.
In short, once you've retrieved the certificate, you're looking for the ValidFromDate and ValidToDate properties.