Afternoon
I am looking to disable special keys such as CTRL+Break, F11 etc.
The code below is in a macros which is my AutoExec - It doesn't debug but also doesn't seem to work at all:
Any help is appreciated
Code:
Dim prp As DAO.Property
Set db = CurrentDb()
Select Case X
Case 1
Set prp = db.CreateProperty("StartUpShowDBWindow", 1, 1)
db.Properties.Append prp
Case 2
Set prp = db.CreateProperty("AllowBreakIntoCode", 1, 1)
db.Properties.Append prp
Case 3
Set prp = db.CreateProperty("AllowSpecialKeys", 1, 1)
db.Properties.Append prp
Case 4
Set prp = db.CreateProperty("AllowToolbarChanges", 1, 1)
db.Properties.Append prp
Case 5
Set prp = db.CreateProperty("AllowFullMenus", 1, 1)
db.Properties.Append prp
Case 6
Set prp = db.CreateProperty("AllowBuiltInToolbars", 1, 1)
db.Properties.Append prp
Case 7
Set prp = db.CreateProperty("AllowByPassKey", 1, 1)
db.Properties.Append prp
Case Else
'do nothing
These properties are loaded before the AutoExec macro fires, and set for the next startup. You need to restart your database before they take effect.
Furthermore, they are boolean properties, which means: db.CreateProperty("StartUpShowDBWindow", 1, False), not db.CreateProperty("StartUpShowDBWindow", 1, 1) if you want to disable certain functionality.
Related
I want to store in a dictionary all the items found in a html table.
I have problems when I have duplicates, because my below code don't store again the item, and I need all the items from this table, even if there is any duplicate.
If I have duplicate values like Round 38, where another Match3 has the same round number, I want to list again those duplicate values.
The results should look like this:
Round 38
Match1
Match2
Round 37
Match1
Match2
Round 38
Match3
Match4
..............
Sub Get_URL_Addresses_test()
Dim URL As String
Dim ie As New InternetExplorer
Dim HTMLdoc As HTMLDocument
Dim dictObj As Object: Set dictObj = CreateObject("Scripting.Dictionary")
Dim tRowID As String
URL = "http://www.flashscore.ro/fotbal/anglia/premier-league-2015-2016/rezultate/"
With ie
.navigate URL
.Visible = True
Do Until .readyState = READYSTATE_COMPLETE: DoEvents: Loop
Set HTMLdoc = .document
End With
For Each objLink In ie.document.getElementsByTagName("a")
If Left(objLink.innerText, 4) = "Show" Or Left(objLink.innerText, 4) = "Arat" Then
objLink.Click
Application.Wait (Now + TimeValue("0:00:01"))
objLink.Click
Application.Wait (Now + TimeValue("0:00:01"))
objLink.Click
Application.Wait (Now + TimeValue("0:00:01"))
'Exit For
End If
Next objLink
With HTMLdoc
Set tblSet = .getElementById("fs-results")
Set mTbl = tblSet.getElementsByTagName("tbody")(0)
Set tRows = mTbl.getElementsByTagName("tr")
With dictObj
For Each tRow In tRows
If tRow.getAttribute("Class") = "event_round" Then
tRowClass = tRow.innerText
'MsgBox tRowClass
If Not .Exists(tRowClass) Then
.add tRowClass, Empty
End If
End If
tRowID = Mid(tRow.ID, 5)
If Not .Exists(tRowID) Then
.add tRowID, Empty
End If
Next tRow
End With
End With
i = 14
For Each Key In dictObj
If Left(Key, 5) = "Runda" Or Left(Key, 5) = "Round" Then
ActiveSheet.Cells(i, 2) = Key
Else
ActiveSheet.Cells(i, 2) = "http://www.flashscore.ro/meci/" & Key & "/#sumar-meci"
End If
i = i + 1
'MsgBox Key
'Debug.Print Key
Next Key
Set ie = Nothing
MsgBox "Process Completed"
End Sub
You could store your items in a generic container that allows duplicates, such as collection or array. But since you are storing them in a dictionary, as keys, it probably means that you want later a fast search for existence of some items. A possible solution would be to "count" the number of appearances of each item (key) and store this number in the corresponding value field.
If tRow.getAttribute("Class") = "event_round" Then
tRowClass = tRow.innerText
dim n as Integer: n = dictObj.Item(tRowClass) ' creates and returns 0 if no exist yet
dictObj.Item(tRowClass) = n + 1
End If
Later you will be able check for the existence of any key in the dictionary and also you have the number of appearances of that key.
EDIT
As I suspected, you're using the dictionary just as a normal container, but since you want to allow for duplicates, Dictiobary is not the way you go. Just use a Collection. Here's the minimal change to your code:
Set dictObj = CreateObject("Scripting.Dictionary") --> Set dictObj = new Collection
If Not .Exists(tRowClass) Then .add tRowClass, Empty End If
Replace the above stuff (3 line) with:
.add tRowClass
That's it.
I've created a public function in Access. My goal is if the next business day is a holiday I'm calculating one extra day of interest for payoff purposes. Below is the working code I have. The issue I'm haveing is I'm dealing with over 35000 records and the time it takes to run the query is too long. If there is a better way of do this I will definitely give it a try. Thanks!
Public Function HolidayInterest(Perdiem As Currency) As Currency
Dim db As Database
Dim rst As Recordset
Select Case DatePart("w", Date)
Case 6
NextBusDay = Date + 3
Case 7
NextBusDay = Date + 2
Case Else
NextBusDay = Date + 1
End Select
Set db = CurrentDb
Set rst = db.OpenRecordset("tbl_Holidays", dbOpenDynaset)
If Not (rst.EOF And rst.BOF) Then
Do While Not rst.EOF
If rst("HolidayDate") = NextBusDay Then
HolidayInterest = Perdiem
Else
HolidayInterest = 0
End If
rst.MoveNext
Loop
Else
'MsgBox "There are no records in the recordset."
End If
'MsgBox "Finished looping through records."
rst.Close 'Close the recordset
Set rst = Nothing 'Clean up
db.Close
Set db = Nothing
End Function
Here is one solution to avoid the opening the Holiday table 35,000 times. It will load all dates into an Array (only once), then use that array for comparing. But I am curious if your existing process ever worked correctly 100% of the time -- if that table contained more than one holiday? Specifically, when you read the holiday table (regardless of the sort order), then in your loop "If rst("HolidayDate") = NextBusDay Then", since you don't exit the loop if you get a match, your subroutine should always return the results of what happens when checking the last date in the table? Also I didn't find a Dim for NextBusDay, so I added it.
Option Compare Database
Option Explicit
Public blnSetArray As Boolean
Public dHolidays() As Date
Public iHolidays As Integer
Public Function HolidayInterest(Perdiem As Currency) As Currency
Dim db As Database
Dim rst As Recordset
Dim i As Integer
Dim iLoop As Integer
Dim NextBusDay As Date
' Save an array of dates the first time
If blnSetArray = False Then
Set db = CurrentDb
Set rst = db.OpenRecordset("tbl_Holidays", dbOpenDynaset)
i = 0
If Not (rst.EOF And rst.BOF) Then
rst.MoveLast
rst.MoveFirst
iHolidays = rst.RecordCount
ReDim dHolidays(rst.RecordCount)
Do While Not rst.EOF
i = i + 1
dHolidays(i) = rst("HolidayDate")
rst.MoveNext
Loop
End If
blnSetArray = True
rst.Close 'Close the recordset
Set rst = Nothing 'Clean up
db.Close
Set db = Nothing
End If
Select Case DatePart("w", Date)
Case 6
NextBusDay = Date + 3
Case 7
NextBusDay = Date + 2
Case Else
NextBusDay = Date + 1
End Select
HolidayInterest = 0 ' Set as default
If iHolidays > 0 Then
For iLoop = 1 To iHolidays
If dHolidays(iLoop) = NextBusDay Then
HolidayInterest = Perdiem
Exit For ' No need to stay in loop
End If
Next iLoop
Else
'MsgBox "There are no records in the recordset."
End If
'MsgBox "Finished looping through records."
End Function
Function MyTest()
blnSetArray = False
Debug.Print HolidayInterest(100#)
End Function
Apart from the Perdiem value you pass as an argument to your function, the only thing that will affect the return value of your function is the current system date as returned by Date. In other words, on any given day your function will always return either the Perdiem value or zero.
Therefore, we can use a Static variable named TheDateToday to hold the current date and you will only have to hit the [tbl_Holidays] table once on any given day:
Option Compare Database
Option Explicit
Public Function HolidayInterest(Perdiem As Currency) As Currency
Dim db As DAO.Database, qdf As DAO.QueryDef, rst As DAO.Recordset
Dim NextBusDay As Date
Static TheDateToday As Date, NextBusDayIsHoliday As Boolean
If CLng(TheDateToday) <> CLng(Date) Then
TheDateToday = Date
Select Case DatePart("w", TheDateToday)
Case 6
NextBusDay = DateAdd("d", 3, TheDateToday)
Case 7
NextBusDay = DateAdd("d", 2, TheDateToday)
Case Else
NextBusDay = DateAdd("d", 1, TheDateToday)
End Select
Set db = CurrentDb
Set qdf = db.CreateQueryDef("", _
"PARAMETERS prmDate DateTime;" & _
"SELECT * FROM tbl_Holidays WHERE HolidayDate=[prmDate]")
qdf!prmDate = NextBusDay
Set rst = qdf.OpenRecordset(dbOpenSnapshot)
NextBusDayIsHoliday = Not (rst.EOF And rst.BOF)
rst.Close
Set rst = Nothing
Set qdf = Nothing
Set db = Nothing
End If
If NextBusDayIsHoliday Then
HolidayInterest = Perdiem
Else
HolidayInterest = 0
End If
End Function
I have code that takes fields from a MS Access form and copies the data into a saved Excel file. The first record in Access in imported to Excel with a range of A2:I2. The second record in Access is imported to Excel with a range of A3:I3, and so on.... What currently happens now is if I close my form in Access and open it back up, and say I already had two records imported into this same Excel file, and now I want to add a third record, it will start over at the first row (A2:I2) and write over what is already there. My question is how can I, if I close and open Access keep it from starting over on (A2:I2), and instead start at the next available row, which to follow the example given would be (A4:I4)? This is the code I have
Private Sub Command73_Click()
Set objXLApp = CreateObject("Excel.Application")
Set objXLBook = objXLApp.Workbooks.Open("Y:\123files\Edmond\Hotel Reservation Daily.xls")
objXLApp.Application.Visible = True
With objXLBook.ActiveSheet
Set r = .usedRange
i = r.Rows.Count + 1
.Cells(i + 1, 1).Value = Me.GuestFirstName & " " & GuestLastName
.Cells(i + 1, 2).Value = Me.PhoneNumber
.Cells(i + 1, 3).Value = Me.cboCheckInDate
.Cells(i + 1, 4).Value = Me.cboCheckOutDate
.Cells(i + 1, 5).Value = Me.GuestNo
.Cells(i + 1, 6).Value = Me.RoomType
.Cells(i + 1, 7).Value = Me.RoomNumber
.Cells(i + 1, 8).Value = Date
.Cells(i + 1, 9).Value = Me.Employee
End With
Set r = Nothing
Set objXLBook = Nothing
Set objXLApp = Nothing
End Sub
You can get the last used row:
Set r = objXLBook.ActiveSheet.UsedRange
i = r.Rows.Count + 1
Some notes.
Private Sub Command73_Click()
''It is always a good idea to put sensible names on command buttons.
''It may not seem like much of a problem today, but it will get there
Dim objXLApp As Object
Dim objXLBook As Object
Dim r As Object
Dim i As Integer
''It is nearly always best to check whether Excel is open before
''opening another copy.
Set objXLApp = CreateObject("Excel.Application")
Set objXLBook = objXLApp.Workbooks.Open( _
"Y:\123files\Edmond\Hotel Reservation Daily.xls")
objXLApp.Application.Visible = True
''It is generally best to specify the sheet
''With objXLBook.ActiveSheet
With objXLBook.Sheets("Room Reservation")
''If the used range includes empty rows
''it may not suit
''Set r = .UsedRange
''i = r.Rows.Count + 1
''From comments, it appears that the data is dense
''but with a number of empty rows at the end of the sheet
i = .Range("A1").End(xlDown).Row + 1
.Cells(i, 1).Value = Me.GuestFirstName & " " & GuestLastName
.Cells(i, 2).Value = Me.PhoneNumber
.Cells(i, 3).Value = Me.cboCheckInDate
.Cells(i, 4).Value = Me.cboCheckOutDate
.Cells(i, 5).Value = Me.GuestNo
.Cells(i, 6).Value = Me.RoomType
.Cells(i, 7).Value = Me.RoomNumber
.Cells(i, 8).Value = Date
.Cells(i, 9).Value = Me.Employee
End With
''Tidy up
Set objXLBook = Nothing
Set objXLApp = Nothing
End Sub
You might also like to look at TransferSpreadsheet.
Another possibility is to use the RecordsetClone, for data from a form, or any recordset, for that matter. It does not give quite the same control, but it is very fast:
Dim objXLApp As Object
Dim objXLBook As Object
Dim r As Object
Dim i As Integer
Dim rs As DAO.Recordset
Set objXLApp = CreateObject("Excel.Application")
objXLApp.Visible = True
Set objXLBook = objXLApp.Workbooks.Open( _
"Y:\123files\Edmond\Hotel Reservation Daily.xls")
Set rs = Me.RecordsetClone
With objXLBook.Sheets("Sheet1")
Set r = .UsedRange
i = r.Rows.Count + 1
.Cells(i, 1).CopyFromRecordset rs
End With
So I'd like to copy a linked table to a local one in code, structure and data in MS Access 2003.
Code being : VBA or C#. Or anything else for that matter..
UPDATE : I want the copy structure and data behaviour from ms access to keep the Primary Keys. If you copy a linked table, you can choose to paste it as 'structure and data (local table)'
It is that I want to achieve in code.
My understanding is that DAO does not support the decimal data type, but ADOX does. Here's an updated procedure that uses ADOX instead to copy the schema to a new table.
One interesting item of note: The OLEDB provider for Jet sorts the columns alphabetically rather than by ordinal position as explained in this KB article. I wasn't concerned about preserving the ordinal position, but you may be, in which case you can update this procedure to meet your needs.
In order for the ADOX version of the code to work, you'll need to set a reference to Microsoft ADO Ext. 2.x for DDL and Security (where x = version number; I used 2.8 to test this procedure). You'll also need a reference to ADO as well.
Public Sub CopySchemaAndData_ADOX(ByVal sourceTableName As String, ByVal destinationTableName As String)
On Error GoTo Err_Handler
Dim cn As ADODB.Connection
Dim cat As ADOX.Catalog
Dim sourceTable As ADOX.Table
Dim destinationTable As ADOX.Table
Set cn = CurrentProject.Connection
Set cat = New ADOX.Catalog
Set cat.ActiveConnection = cn
Set destinationTable = New ADOX.Table
destinationTable.Name = destinationTableName
Set sourceTable = cat.Tables(sourceTableName)
Dim col As ADOX.Column
For Each col In sourceTable.Columns
Dim newCol As ADOX.Column
Set newCol = New ADOX.Column
With newCol
.Name = col.Name
.Attributes = col.Attributes
.DefinedSize = col.DefinedSize
.NumericScale = col.NumericScale
.Precision = col.Precision
.Type = col.Type
End With
destinationTable.Columns.Append newCol
Next col
Dim key As ADOX.key
Dim newKey As ADOX.key
Dim KeyCol As ADOX.Column
Dim newKeyCol As ADOX.Column
For Each key In sourceTable.Keys
Set newKey = New ADOX.key
newKey.Name = key.Name
For Each KeyCol In key.Columns
Set newKeyCol = destinationTable.Columns(KeyCol.Name)
newKey.Columns.Append (newKeyCol)
Next KeyCol
destinationTable.Keys.Append newKey
Next key
cat.Tables.Append destinationTable
'Finally, copy data from source to destination table
Dim sql As String
sql = "INSERT INTO " & destinationTableName & " SELECT * FROM " & sourceTableName
CurrentDb.Execute sql
Err_Handler:
Set cat = Nothing
Set key = Nothing
Set col = Nothing
Set sourceTable = Nothing
Set destinationTable = Nothing
Set cn = Nothing
If Err.Number <> 0 Then
MsgBox Err.Number & ": " & Err.Description, vbCritical, Err.Source
End If
End Sub
Here's the original DAO procedure
Public Sub CopySchemaAndData_DAO(SourceTable As String, DestinationTable As String)
On Error GoTo Err_Handler
Dim tblSource As DAO.TableDef
Dim fld As DAO.Field
Dim db As DAO.Database
Set db = CurrentDb
Set tblSource = db.TableDefs(SourceTable)
Dim tblDest As DAO.TableDef
Set tblDest = db.CreateTableDef(DestinationTable)
'Iterate over source table fields and add to new table
For Each fld In tblSource.Fields
Dim destField As DAO.Field
Set destField = tblDest.CreateField(fld.Name, fld.Type, fld.Size)
If fld.Type = 10 Then
'text, allow zero length
destField.AllowZeroLength = True
End If
tblDest.Fields.Append destField
Next fld
'Handle Indexes
Dim idx As Index
Dim iIndex As Integer
For iIndex = 0 To tblSource.Indexes.Count - 1
Set idx = tblSource.Indexes(iIndex)
Dim newIndex As Index
Set newIndex = tblDest.CreateIndex(idx.Name)
With newIndex
.Unique = idx.Unique
.Primary = idx.Primary
'Some Indexes are made up of more than one field
Dim iIdxFldCount As Integer
For iIdxFldCount = 0 To idx.Fields.Count - 1
.Fields.Append .CreateField(idx.Fields(iIdxFldCount).Name)
Next iIdxFldCount
End With
tblDest.Indexes.Append newIndex
Next iIndex
db.TableDefs.Append tblDest
'Finally, copy data from source to destination table
Dim sql As String
sql = "INSERT INTO " & DestinationTable & " SELECT * FROM " & SourceTable
db.Execute sql
Err_Handler:
Set fld = Nothing
Set destField = Nothing
Set tblDest = Nothing
Set tblSource = Nothing
Set db = Nothing
If Err.Number <> 0 Then
MsgBox Err.Number & ": " & Err.Description, vbCritical, Err.Source
End If
End Sub
try docmd.CopyObject or docmd.TransferDatabase
Create this query and execute it
SELECT * INTO MyNewTable FROM LinkedTableName
In VBA you can do
docmd.runsql "SELECT * INTO MyNewTable FROM LinkedTableName"
To keep the structure you would have to do DoCmd.TransferDatabase acImport
Anyway to Erase multiple forms, queries, etc in Access 2000? (In the designer that is).
This worked better for me. Trying to remove the elements in the loop itself kept having trouble. I just slapped the object names into an array, then deleted them afterward.
Public Sub DeleteAllFormsAndReports()
Dim accobj As AccessObject
Dim X As Integer
Dim iObjCount As Integer
Dim sObjectNames() As String
If MsgBox("Are you sure you want to delete all of the forms and reports?", vbCritical + vbYesNo) = vbYes Then
ReDim sObjectNames(0)
For Each accobj In CurrentProject.AllForms
ReDim Preserve sObjectNames(UBound(sObjectNames) + 1)
sObjectNames(UBound(sObjectNames)) = accobj.Name
Next accobj
For X = 1 To UBound(sObjectNames)
DoCmd.DeleteObject acForm, sObjectNames(X)
Next X
ReDim sObjectNames(0)
For Each accobj In CurrentProject.AllReports
ReDim Preserve sObjectNames(UBound(sObjectNames) + 1)
sObjectNames(UBound(sObjectNames)) = accobj.Name
Next accobj
For X = 1 To UBound(sObjectNames)
DoCmd.DeleteObject acReport, sObjectNames(X)
Next X
End If
End Sub
I create a lot of queries on the fly when a user performs certain actions. So, I'll create the query, then delete the query once they close the form. I do this under the On Close event. It runs regardless of whether the query was created or not. So, to prevent an error, I tell it to Resume Next.
Private Sub Form_Close()
On Error Resume Next
DoCmd.Close acReport, "EmployeeDetails"
DoCmd.DeleteObject acQuery, "MyEmployeeDetails"
End Sub
You can delete objects with VBA. Be sure to step backwards when deleting from a collection, for example, this code will delete quite a few objects:
Dim db As Database
Dim idx As Long
Dim strName As String
Set db = CurrentDb
''Forms
For idx = CurrentProject.AllForms.Count - 1 To 0 Step -1
strName = CurrentProject.AllForms(idx).Name
DoCmd.DeleteObject acForm, strName
Next idx
''Reports
For idx = CurrentProject.AllReports.Count - 1 To 0 Step -1
strName = CurrentProject.AllReports(idx).Name
DoCmd.DeleteObject acReport, strName
Next idx
''Modules
For idx = CurrentProject.AllModules.Count - 1 To 0 Step -1
strName = CurrentProject.AllModules(idx).Name
If strName <> "Module9" Then
DoCmd.DeleteObject acModule, strName
End If
Next idx
''Queries
For idx = db.QueryDefs.Count - 1 To 0 Step -1
strName = db.QueryDefs(idx).Name
If Left(strName, 4) <> "~sq_" Then
db.QueryDefs.Delete strName
Else
Debug.Print strName
End If
Next idx
''Relationships
For idx = db.Relations.Count - 1 To 0 Step -1
strName = db.Relations(idx).Name
If Left(strName, 4) <> "msys" Then
db.Relations.Delete strName
Else
Debug.Print strName
End If
Next idx
''Tables
For idx = db.TableDefs.Count - 1 To 0 Step -1
strName = db.TableDefs(idx).Name
If Left(strName, 4) <> "msys" Then
db.TableDefs.Delete strName
Else
Debug.Print strName
End If
Next idx