I'm trying to create a script to automatically grant select,update,delete,insert on tables to specific users.
Dim ModelTables, table, tab, newPerm
SET ModelTables = obj.Tables
For Each table in ModelTables
If IsObject(table) Then
Set tab = table
'Testing just on one table
If InStr(tab.Name, "MY_TEST_TABLE")=1 Then
set newPerm = tab.Permissions.createNew()
'-- this is all I managed to create
End If
End if
Next
This is all I managed to create. I don't know the structure of a Permission. I'm also totaly new to VB. Can somebody support me with a hint / proper code / documentation, please?
Here is a sample to create new permissions, and list the existing ones.
option explicit
dim obj
set obj = activemodel
dim ModelTables : set ModelTables = obj.Tables
dim u : set u = Finduser("User_1")
if not u is nothing then
dim table
For Each table in ModelTables
If IsObject(table) Then
dim tab
Set tab = table
dim p
if tab.Permissions.count = 0 then
output "creating permission on " & tab.name
set p = tab.Permissions.createNew
set p.DBIdentifier = u
p.grant = "SELECT,DELETE,INSERT,UPDATE"
end if
' show permissions
output "permissions on " & tab.name
for each p in tab.Permissions
output " for user " & p.DBIdentifier & " : " & p.grant
next
End if
Next
end if
function FindUser(name)
dim u
for each u in activemodel.users
if u.name = name then
set FindUser = u
output "found user"
end if
next
end function
Related
I learned a couple of weeks ago how to update an Excel file via ADO. At that time the value was already given before changing it.
Now I want to add the procedure of reading the current value in the same cell and assign the value to a variable before changing it!
The current procedure looks as follows:
Public Sub ChangeNum()
Dim con As ADODB.Connection, rec As ADODB.Recordset
Dim sqlstr As String, datasource As String
Set con = New ADODB.Connection: Set rec = New ADODB.Recordset
datasource = "D:\DropBox\TraderShare\TraderNum.xlsx"
Dim sconnect As String
sconnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & datasource & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
con.Open sconnect
sqlstr = "UPDATE [Sheet1$] SET [Number] = """ & gsvDocNum & """ WHERE [ID] = """ & svNumRng & """"
rec.Open sqlstr, con ', adOpenUnspecified, adLockUnspecified 'adLockOptimistic , adOpenStatic, adLockReadOnly
con.Close
Set rec = Nothing: Set con = Nothing
End Sub
gsvDocNum is a global string variable declared in the beginning of the initial startup routine, hence after reading the current value into the variable, the UPDATE one will write gsvDocNum + 1 to the file.
svNumRng is one of the following named ranges, PNum, SNum, TNum or INum declared in the beginning of the main routine and determined which one to look for in an earlier stage (if it’s an Purchase, SalesOrder, TradeOrder or an Invoice).
I’m not so familiar with ADO and SQL strings and I can’t find the proper syntax for SELECT for reading the current cell value and assign it to a variable before changing it with the UPDATE.
Grateful for any help!
OK, the background as follows: We have an administrative program I’ve written myself in Excel vba for registering purchases, orders and invoices, etc. It works pretty well for our requirements but has one issue, keeping order numbers synced between the users! We are 3 users using the program locally, each one registering orders and such, but we share the serial number file via a shared DropBox folder. I have the idea that using ADO/SQL without opening the Excel file would be faster than open, change and save the file in Excel. The reason is of course to minimize the time updating the file thus the delay before syncing to the cloud Dropfox location and to the other users computers is minimized. It’s a simple 2 column Excel file, TraderNum.xlsx:
ID Number
PNum 16000
SNum 16000
TNum 16132
INum 16173
I learned a couple of weeks ago how to change one of the numbers from Excel without opening the file using ADO/SQL, (see above). But I discovered that a constant update of the Excel link to a closed file for having the current number available before changing it doesn’t work as expected. Accordingly I want to use ADO/SQL also to read/assign the specific current number to a variable in the Excel procedure, before changing it with the ADO/SQL procedure above.
So somewhere between the 2 commands, rec.Open sconnect and con.Close there should be a SQL-string similar to:
sqlread = "SELECT """ & DocNumOld & """ = [Number] FROM [Sheet1$] Where [ID] = """ & svNumRng & """"
where the DocNumOld variable is assigned the current number from the chosen ID variable svNumRng.
Then the DocNumNew variable is and assigned with the DocNumOld variable incremented with 1 followed by the
sqlUpdate sequence. It should look similar to the following:
Public Sub ChangeNum()
Dim con As ADODB.Connection, rec As ADODB.Recordset
Dim sqlRead as String, sqlUpdate As String, datasource As String, sconnect As String
Set con = New ADODB.Connection: Set rec = New ADODB.Recordset
datasource = "D:\DropBox\TraderShare\TraderNum.xlsx"
sconnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & datasource & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
con.Open sconnect
sqlRead = "SELECT """ & DocNumOld & """ = [Number] FROM [Sheet1$] Where [ID] = """ & svNumRng & """"
sqlUpdate = "UPDATE [Sheet1$] SET [Number] = """ & DocNumNew & """ WHERE [ID] = """ & svNumRng & """"
rec.Open ???????, con
????? sqlRead
DocNumNew = DocNumOld + 1
UNION
????? sqlUpdate
con.Close
Set rec = Nothing: Set con = Nothing
End Sub
Can you solve this, please?
Can anyone give me a solution to how to use ADO/SQL also to read/assign one specific current number to a variable in an Excel procedure, before changing it with the ADO/SQL procedure?
I am concerned I don't understand your question, because the resulting comments don't make sense to me.
To restate your problem: you need to know the value of some cell, and be able to feed it into your code.
You can already connect to a worksheet with SQL, you already know what SELECT statements are, and you probably already know how to run them. Humor me.
sqlRead = "SELECT * FROM [Sheet1$A12:F48]"
Set rec = con.Execute(sqlRead)
Now you have a recordset rec that contains the whole table. Say you wanted to put every value of the entire table in your immediate window:
Do While Not rec.EOF
For i = 0 To rec.Fields.Count - 1
Debug.Print rec.Fields(i).Name, rec.Fields(i).Value
Next
rec.MoveNext
Loop
Don't forget to close it, and I suggest using a second variable name anyway as the name of the recordset for the update statement.
rec.Close
Say you knew the cell would always be in the 3rd row, 8th column of the table you are selecting from, you might:
For j = 0 to myRowNum-1 'you have set myRowNum equal to 3 earlier'
rec.MoveNext
Next
myOldCellValue = rec.Fields(myColNum-1).value 'you have set myColNum to 8 earlier'
rec.Close
Now, say you don't know exactly which row you will find myOldCellValue, but you know it will be found in the 4th column of the row that has the unique [ID] 1234, you might:
sqlRead = "SELECT * FROM [Sheet1$A12:F48] Where [ID] = """ & myIDNum & """" 'you have set myIDNum to 1234 earlier
Set rec = con.Execute(sqlRead)
myOldCellValue = rec.Fields(myColNum-1).value 'you have set myColNum to 4 earlier'
rec.Close
Say you wanted to UPDATE every row that had that value (I don't read that you, but for completeness), you might:
sqlUpdate="UPDATE [Sheet1$] SET [Number] = """ & DocNumNew & """ WHERE [DocNum] = """ & myOldCellValue & """"
Public Sub RemDups()
Dim t As Items, _
i As Integer, _
arr As Collection, _
f As Folder, _
parent As Folder, _
target As Folder, _
miLast As MailItem, _
mi As MailItem
Set parent = Application.GetNamespace("MAPI").PickFolder
Set target = Application.GetNamespace("MAPI").PickFolder
For Each f In parent.Folders
Set t = f.Items
t.Sort "[Subject]"
i = 1
Set miLast = t(i)
Set arr = New Collection
While i < t.Count
i = i + 1
If TypeName(t(i)) = "MailItem" Then
Set mi = t(i)
If miLast.Subject = mi.Subject And miLast.Body = mi.Body _
And miLast.ReceivedTime = mi.ReceivedTime Then
arr.Add mi
Else
Set miLast = mi
End If
End If
Wend
For Each mi In arr
mi.Move target
Next mi
Next f
End Sub
Set miLast = t(i) gives "Run-time error'440' Array index out of bounds
Please help
This is a modified version founded in the web (Blog ExcelandAccess)
This code let pick a folder to search and delete duplicate items.
Option Explicit
'Set a reference to the Microsoft Scripting Runtime from Tools, References.
Sub DeleteDuplicateEmailsInSelectedFolder()
Dim i As Long
Dim n As Long
Dim Message As String
Dim Items As Object
Dim AppOL As Object
Dim NS As Object
Dim Folder As Object
Set Items = CreateObject("Scripting.Dictionary")
'Initialize and instance of Outlook
Set AppOL = CreateObject("Outlook.Application")
'Get the MAPI Name Space
Set NS = AppOL.GetNamespace("MAPI")
'Allow the user to select a folder in Outlook
Set Folder = NS.PickFolder
'Get the count of the number of emails in the folder
n = Folder.Items.Count
'Check each email starting from the last and working backwards to 1
'Loop backwards to ensure that the deleting of the emails does not interfere with subsequent items in the loop
For i = n To 1 Step -1
On Error Resume Next
'Load the matching criteria to a variable
'This is setup to use the Sunject and Body, additional criteria could be added if desired
Message = Folder.Items(i).Subject & "|" & Folder.Items(i).Body
'Check a dictionary variable for a match
If Items.Exists(Message) = True Then
'If the item has previously been added then delete this duplicate
Folder.Items(i).Delete
Else
'In the item has not been added then add it now so subsequent matches will be deleted
Items.Add Message, True
End If
Next i
ExitSub:
'Release the object variables from memory
Set Folder = Nothing
Set NS = Nothing
Set AppOL = Nothing
End Sub
A better version is to find duplicate e-mails in other folder in recursive mode.
we have a problem with the access linked table wizard. We would like to transfer access tables to an sql server and then link the tables. We would like to have the option that multiple users can do this. Currently we discover that it is only possible to link tables successfully if we use an sql account with sysadmin rights or if the sql user is the owner of the destination database.
Is there a way to enable users creating linked tables without having sysadmin rights and being the owner of the destination database? I thought it would be possible to create linked tables if I use an sql user with the db_owner role assigned for the destination db, but this does not work.
Please help me.
Thank you in advance.
Kind regards
Florian
This answer was long in coming. I modified the code from here and changed it to copy from a local table to a table in SQL Server.
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 cnSQL As ADODB.Connection
Dim catSQL As ADOX.Catalog
Dim sourceTable As ADOX.Table
Dim destinationTable As ADOX.Table
Set cnSQL = New ADODB.Connection
'Set cnSQL = CurrentProject.Connection
cnSQL.Provider = "MSDASQL"
cnSQL.ConnectionString = gstrOLEDBConnection 'put your connection string here. the user needs to be able to create tables on the database
cnSQL.Open
Set catSQL = New ADOX.Catalog
Set catSQL.ActiveConnection = cnSQL
Set destinationTable = New ADOX.Table
destinationTable.Name = destinationTableName
Set cn = CurrentProject.Connection
Set cat = New ADOX.Catalog
Set cat.ActiveConnection = cn
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
catSQL.Tables.Append destinationTable
'To do...
'Link the new sql table
'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 catSQL = Nothing
Set key = Nothing
Set col = Nothing
Set sourceTable = Nothing
Set destinationTable = Nothing
Set cnSQL = Nothing
Set cn = Nothing
If Err.Number <> 0 Then
msgBox Err.Number & ": " & Err.Description, vbCritical, Err.Source
End If
End Sub
Im looking for a VBScript that will automatically send an email to each person on a list of contacts I have in an excel tabel using a mail merge.
Any help would be much appreciated and if you need more info just ask :)
Basically I have this code
Sub SendMessage(DisplayMsg As Boolean, Optional AttachmentPath)
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("Nancy Davolio")
objOutlookRecip.Type = olTo
' Set the Subject, Body, and Importance of the message.
.Subject = "This is an Automation test with Microsoft Outlook"
.Body = "This is the body of the message." &vbCrLf & vbCrLf
.Importance = olImportanceHigh 'High importance
' Resolve each Recipient's name.
For Each ObjOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next
' Should we display the message before sending?
If DisplayMsg Then
.Display
Else
.Save
.Send
End If
End With
Set objOutlook = Nothing
End Sub
But I need it to, instead of creating an email, it uses a mail merge, and the email is to be sent to everyone on a list stored in an excel sheet, problem is, I have no idea how to do this so any help would be great!
Thanks
This will send one email to each person listed in an excel file. For this example, the name is in column A, the email address is in column B and the subject is in column C. Create a template in the drafts folder and set the subject to "Template". In the template email, use {} around any field you want to replace with another. In this example, {name} is replaced with the name from column A. Insert the {image} tag where you want the image to go. I'm assuming you want the same image since it's a corporate logo, so you just define the path in the SendMessage Sub. This will add the image as an attachment, there is no easy way to get around that but it will be embedded into the body of the email.
set app = CreateObject("Excel.Application")
Set wb = app.Workbooks.Open ("H:\Book1.xls")
'skip header row. set to 1 if you
'don't have a header row
set sh = wb.Sheets("Sheet1")
row = 2
name = sh.Range("A" & row)
email = sh.Range("B" & row)
subject = sh.Range("C" & row)
'image = sh.Range("D" & row)
LastRow = sh.UsedRange.Rows.Count
For r = row to LastRow
If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then
SendMessage email, name, subject, TRUE, _
NULL, "H:\Scripts\Batch\pic.png", 80,680
row = row + 1
name = sh.Range("A" & row)
email = sh.Range("B" & row)
subject = sh.Range("C" & row)
'image = sh.Range("D" & row)
End if
Next
wb.close
set wb = nothing
set app = nothing
Sub SendMessage(EmailAddress, DisplayName, Subject, DisplayMsg, AttachmentPath, ImagePath, ImageHeight, ImageWidth)
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
template = FindTemplate()
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(EmailAddress)
objOutlookRecip.resolve
objOutlookRecip.Type = 1
' Set the Subject, Body, and Importance of the message.
.Subject = Subject
.bodyformat = 3
.Importance = 2 'High importance
body = Replace(template, "{name}", DisplayName)
if not isNull(ImagePath) then
if not ImagePath = "" then
.Attachments.add ImagePath
image = split(ImagePath,"\")(ubound(split(ImagePath,"\")))
body = Replace(body, "{image}", "<img src='cid:" & image & _
"'" & " height=" & ImageHeight &" width=" & ImageWidth & ">")
end if
else
body = Replace(body, "{image}", "")
end if
if not isNull(AttachMentPath) then
.Attachments.add AttachmentPath
end if
.HTMLBody = body
' Should we display the message before sending?
If DisplayMsg Then
.Display
Else
.Save
.Send
End If
End With
Set objOutlook = Nothing
End Sub
Function FindTemplate()
Set OL = GetObject("", "Outlook.Application")
set Drafts = OL.GetNamespace("MAPI").GetDefaultFolder(16)
Set oItems = Drafts.Items
For Each Draft In oItems
If Draft.subject = "Template" Then
FindTemplate = Draft.HTMLBody
Exit Function
End If
Next
End Function
I have an access database with many tables. I am looking for a field which may or may not exist in one or many of the tables. How do I check if it exists or not? (without querying each table of course)
There is a schema for fields:
Set cn = CurrentProject.Connection
SelectFieldName = "SomeFieldName"
'Get names of all tables that have a column = SelectFieldName '
Set rs = cn.OpenSchema(adSchemaColumns, _
Array(Empty, Empty, Empty, SelectFieldName))
From: MS Access: How to bypass/suppress an error?
If you really do not want to open any table, a solution is to use the tabledefs collection of the database object. Each tabledef item has its own fields collection that you can browse. It would give something like that:
Public function findFieldInDatabase(p_myFieldName)
dim db as database, _
tb as tabledef, _
fd as field
set db = currentDb
for each tb in db.tabledefs
for each fd in tb.fields
if fd.name = p_myFieldName then
debug.print tb.name, fd.name
end if
next fd
next tb
set fd = nothing
set tb = nothing
set db = nothing
end function
This code could be easily adapted to accept an optional p_myTableName as an argument to limit the search to a table/range of tables.
Here's what I would do if I wanted to see if a particular column (identified in strSearch) in a particular table.
Public Sub search()
Dim db As Database
Dim strSearch As String
Dim strSQL As String
Dim rsResults As Recordset
Dim i As Integer
Dim cols As Integer
strSearch = "a3"
Set db = CurrentDb
strSQL = "select * from bar"
Set rsResults = db.OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly)
If Not rsResults.BOF Then
rsResults.MoveFirst
End If
cols = rsResults.Fields.Count - 1 ' -1 because we start counting cols at 0
For i = 0 To cols
If rsResults(i).Name = strSearch Then
MsgBox "Found the seach string"
End If
Next
MsgBox "end of script"
End Sub
Now I know you don't want to write one of those for each table. So the next thing to do would be to loop through all the tables. You can find a list of all the tables with the following SQL
SELECT
name
FROM
MSysObjects
WHERE
(Left([Name],1)<>"~")
AND (Left([Name],4) <> "MSys")
AND ([Type] In (1, 4, 6))
Connecting these two pieces up together, I'll leave as an exercise for the student :)
Here's how you access the table schema in MS Access using VBScript:
TestData = "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=c:\somefolder\YOURDB.mdb"
Set Conn = Server.CreateObject("ADODB.Connection")
Conn.Open TestData
Set rs = Conn.OpenSchema(4)
do until Rs.eof
tn = RS("TABLE_NAME")
fn = RS("COLUMN_NAME")
' your script goes here
loop
Here you go:
Public Function fTableExists(ByVal vstrTable As String) As Boolean
Dim rs As ADODB.Recordset
Set rs = CurrentProject.Connection.OpenSchema( _
adschematables, Array(Empty, Empty, vstrTable))
fTableExists = Not rs.EOF
rs.Close
Set rs = Nothing
End Function
Public Function fColumnExists(ByVal vstrTable As String, _
ByVal vstrColumn As String) As Boolean
Dim rs As ADODB.Recordset
Set rs = CurrentProject.Connection.OpenSchema(adSchemaColumns, _
Array(Empty, Empty, vstrTable, vstrColumn))
fColumnExists = Not rs.EOF
rs.Close
Set rs = Nothing
End Function
MSSQL
Looking for ADDRESS1 column:
select so.name from sysobjects so
where so.id in (select sc.id from syscolumns sc where name like 'ADDRESS1')
ORACLE
http://en.wikipedia.org/wiki/Oracle_metadata
Google will find the syntax for other DBs...
What type of database is it? If it's SQL Server you can try this:
SELECT * FROM sysobjects WHERE xtype = 'U' AND name = 'myTable'
But since it's the column you're looking for and not a table (thanks Brian), try this:
SELECT
DISTINCT
so.[name] AS 'Table',
sc.[name] AS 'Column'
FROM
syscolumns sc
JOIN
sysobjects so
ON
so.id = sc.id
WHERE
sc.[name] = 'myTable'