Re: Update DB table from visual basic script
- From: Robert Schott <robsmiler@xxxxxxxxxxxxxx>
- Date: Wed, 25 Mar 2009 09:33:27 +0100
Hello,
wrote this code in VB6 a couple of years back. I do not modify it - just grabbed it out of that project. Did a lot of research if things like this are possible at all. You will find regular SQL stmts, automation things and something I was very proud of - code injection. Yes you can also inject and start vb code from the outside (no I'm no bad guy - I needed it for a customer not to write trojans :) ).
Beware: I've never tested things with newer versions of Access >2000. With acc2k.mdb this worked very well. I assume that with some effort it should be possible to port over to vbscript, too.
I hope this will lead you to your solution.
rob*
mcolson wrote:
Is it possible to update a DB table from a visual basic script ran out
side of Access? I have a database that is used at multiple sites
(each has their own copy). I would like to give each site a .vbs file
and have them run it. Will this work? I found the following and am
hoping to modify it so it will work as a vbs file.
Sub CreateTableX1()
Dim dbs As Database
' Modify this line to include the path to Northwind
' on your computer.
dbs = OpenDatabase("C:\Documents and Settings\molson\Desktop
\Reports.mdb")
' Create a table with two text fields.
dbs.Execute("CREATE TABLE ThisTable " & "(FirstName CHAR,
LastName CHAR);")
dbs.Close()
End Sub
Attribute VB_Name = "mDbUpdate"
'*************************************************************
' This program provides remote updating facilities for MS-Jet
' data. With it one can update MDB databases when
' DAO/JET >= 3.51 is installed.
'*************************************************************
' Version: 1.0.3 (c) 2001 roottec.com / R. Schott
'*************************************************************
' 2001-12-28
' Scripting host has several compatibility issues. So I changed
' the reference from statical bound to late binding.
'*************************************************************
Option Explicit
Global Const C_AppTitle = "AK_data Version %s >> Euro-Umstellung"
Global Const C_DefaultPath = "C:\Programme\MemSys\kinzinger\AK_data.mdb"
Global Const C_DB_version = "0.2.2"
'*************************************************************
'* MAIN UPDATE ROUTINE *
'*************************************************************
Public Function UpdateDB(dbName As String) As Boolean
Dim dbs As dao.Database, qdf As dao.QueryDef, wrkJet As dao.Workspace, s As String
UpdateDB = True
' das connection object darf aus welchem Grunde auch immer NICHT
' für das Aktualisieren der Datensätze verwendet werden. Wie bereits
' schon bei IDG einmal festgestellt vertragen sich DAO und ADO
' im gemischten Betrieb nicht (immer).
Set wrkJet = CreateWorkspace("", "admin", "", dbUseJet)
Set dbs = wrkJet.OpenDatabase(dbName, False, False) ' CurrentDb
' Debug.Print Err.Number & " : " & Err.Description
On Error Resume Next
' TArtikelliste behandeln
s = "UPDATE TArtikelliste SET TArtikelliste.EK = round((TArtikelliste.EK/1.95583),2);"
dbs.Execute s
If Err.Number <> 0 Then
MsgBox Err.Description, vbCritical, "ErrNo: " & Err.Number
UpdateDB = False
End If
s = "UPDATE TAuftragsDetails SET TAuftragsDetails.Einzelpreis = Round((TAuftragsDetails.Einzelpreis/1.95583),2);"
Debug.Print s
dbs.Execute s, dbFailOnError
If Err.Number <> 0 Then
MsgBox Err.Description, vbCritical, "ErrNo: " & Err.Number
UpdateDB = False
End If
s = "UPDATE TAuftragsDetails SET TAuftragsDetails.Aufschlag = 0, TAuftragsDetails.Einzelpreis = 0 WHERE (((TAuftragsDetails.Aufschlag)=-1));"
Debug.Print s
dbs.Execute s, dbFailOnError
If Err.Number <> 0 Then
MsgBox Err.Description, vbCritical, "ErrNo: " & Err.Number
UpdateDB = False
End If
s = "SELECT TAuftragsDetails.Gruppen_ID, Sum(round([Einzelpreis]*[Stück]*(1+[Aufschlag]),2)) AS Preis, Sum(round((round(([Einzelpreis]*[Stück]*(1+[Aufschlag])),2)*[Prozentwert]),2)) AS MwSt, Sum(([Einzelpreis]-[AktEK])*[Stück]) AS Rohgewinn " & _
"FROM TSteuersatztabelle LEFT JOIN TAuftragsDetails ON TSteuersatztabelle.ID = TAuftragsDetails.Steuer_ID " & _
"WHERE (((TAuftragsDetails.bAlternativPreis) = False) And ((TAuftragsDetails.Einzelpreis) Is Not Null)) " & _
"GROUP BY TAuftragsDetails.Gruppen_ID;"
Debug.Print "Create Gruppen Helper Query.."
Dim r As dao.Recordset
' Set cn = Nothing
Set qdf = dbs.CreateQueryDef("aQ__Group", s)
' ... cut out some ...
dbs.QueryDefs.Delete "aQ__Group"
dbs.Close
End Function
'*************************************************************
'* MAIN UPDATE ROUTINE (end) *
'*************************************************************
Public Function updateDB_fname(fname As String) As Boolean
Dim bErr As Boolean, s As String
updateDB_fname = True
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Len(fname) > 0 Then
If Not objFSO.FileExists(fname) Then
MsgBox "Bitte DB-Pfad überprüfen", vbCritical, "DB-Pfad falsch:"
Exit Function
End If
updateDB_fname = UpdateDB(fname)
Else
updateDB_fname = False
End If
End Function
Public Function updateDB_1_1() As Boolean
Dim bErr As Boolean, s As String
updateDB_1_1 = True
On Error Resume Next
Dim cn As New ADODB.Connection
cn.Mode = adModeShareExclusive
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=Y:\cSquare\data.mdb;"
If Err.Number <> 0 Then
MsgBox Err.Description, vbCritical, "ErrNo: " & Err.Number
updateDB_1_1 = False: Exit Function
End If
cn.Execute "ALTER TABLE cars ADD COLUMN bReserved YESNO;"
If Err.Number <> 0 Then
MsgBox "bReserved konnte nicht angelegt werden. Bereits da?", vbInformation
updateDB_1_1 = False
End If
cn.Execute "ALTER TABLE cars ADD COLUMN bSold YESNO;"
If Err.Number <> 0 Then
MsgBox "bSold konnte nicht angelegt werden. Bereits da?", vbInformation
updateDB_1_1 = False
End If
cn.Execute "ALTER TABLE cars_p ADD COLUMN brutto_payed CURRENCY;"
If Err.Number <> 0 Then
MsgBox "brutto_payed konnte nicht angelegt werden. Bereits da?", vbInformation
updateDB_1_1 = False
End If
s = "UPDATE cars_p SET cars_p.brutto_payed = [payed], cars_p.payed = [payed]/1.16 " & _
"WHERE (((cars_p.brutto_payed) Is Null) AND ((cars_p.payed) Is Not Null));"
cn.Execute s
If Err.Number <> 0 Then
MsgBox Err.Description, vbCritical, "ErrNo: " & Err.Number
updateDB_1_1 = False
End If
End Function
' injects code of function 'AddApplicationProperty' into target mdb
Public Function addFuncAppProperty(A As Access.Application) As Integer
' first we need to know if proc 'AddApplicationProperty' already is in one module
Dim m As Module, sProcCode As String, i As Integer, bProcFound As Boolean
bProcFound = False
For i = 0 To A.Modules.Count - 1
Set m = A.Modules(i)
Debug.Print m.Name
sProcCode = getCodeComplete(A, m.Name, "AddApplicationProperty")
If Len(sProcCode) > 0 Then
bProcFound = True: Exit For
End If
Next i
If Not bProcFound Then
Dim sInjectTag As String, sInjectBody As String
sInjectTag = "'<!--- Injected code from vbUpdater ( " & Format(Date, "mm-dd-yyyy") & " ) --->"
sInjectBody = "'" & vbCrLf & sInjectTag & _
setCode_FunctionAddApplicationProperty() & vbCrLf & _
sInjectTag
A.Modules(0).AddFromString sInjectBody
End If
End Function
' adds version comment to the first module found (if any - otherwise nothing!)
Public Function addVersionInfo(targetDb As String, newVersion As String, author As String) As Integer
Dim oAcc As New cAccessCtrl, A As Access.Application
Dim m As Module
If Not oAcc.Init(targetDb, True, True) Then
MsgBox oAcc.ErrDescription, vbCritical, "ErrorNo. " & oAcc.AccErr: Exit Function
End If
Set A = oAcc.ObjAccApplication
If A.Modules.Count > 0 Then ' insert new version info as comment in first module avail
Dim sInjectVersionTag As String
sInjectVersionTag = "'<!--- Version " & newVersion & _
" (" & Format(Date, "mm-dd-yyyy") & ") " & author & _
" --->"
A.Modules(0).AddFromString sInjectVersionTag
Else
MsgBox "Missing code module in" & vbCrLf & _
"'" & targetDb & "'" & vbCrLf & _
"So I could not inject code to set app title"
End If
End Function
' enables/disables to circumvent to start autoexec makro or form or sub...
Public Function allowBypassKey(targetDb As String, bFlag As Boolean) As Integer
Dim oAcc As New cAccessCtrl, A As Access.Application
If Not oAcc.Init(targetDb, True, True) Then
MsgBox oAcc.ErrDescription, vbCritical, "ErrorNo. " & oAcc.AccErr: Exit Function
End If
Set A = oAcc.ObjAccApplication
addFuncAppProperty A
A.Run "AddApplicationProperty", "AllowBypassKey", DB_BOOLEAN, bFlag
' A.CodeData
' A.CodeProject
End Function
' returns complete code of a given module.proc
Public Function getCodeComplete(A As Access.Application, _
strModulname As String, _
strProcName As String) As String
Dim mdl As Access.Module
Dim lineBegin As Long, lineProcStart As Long
Dim lineCount As Long, lineProcEnd As Long
Dim sHead As String, sBody As String
getCodeComplete = ""
' A.DoCmd.OpenModule strModulname
Set mdl = Modules(strModulname)
On Error Resume Next ' if proc does not exist then return blank string
' get number of lines in proc
lineCount = mdl.ProcCountLines(strProcName, vbext_pk_Proc)
If Err.Number = 35 Then ' sub or func NOT defined
Exit Function
ElseIf Err.Number <> 0 Then
MsgBox "Err: mDbUpdate.getCodeComplete(" & strModulname & "," & strProcName & ")" & vbCrLf & _
Err.Description, vbCritical, "Severe Error#: " & Err.Number
End If
On Error GoTo 0
' get line number of proc header
lineBegin = mdl.ProcStartLine(strProcName, vbext_pk_Proc)
' line number of proc body starts
lineProcStart = mdl.ProcBodyLine(strProcName, vbext_pk_Proc)
' all lines right before proc definition - aka comments
sHead = mdl.Lines(lineBegin, lineProcStart - lineBegin)
' Die Nummer der letzten Zeile der Prozedur ermitteln.
lineProcEnd = (lineProcStart + lineCount - 1) - Abs(lineProcStart - lineBegin)
' all proc lines
sBody = mdl.Lines(lineProcStart, (lineProcEnd - lineProcStart) + 1)
getCodeComplete = sHead & vbCrLf & sBody
End Function
Public Function get_version() As String
On Error Resume Next
get_version = App.Major & "." & App.Minor & "." & App.Revision
End Function
Public Function modify_ApplicationTitle(A As Access.Application, newTitle As String) As Integer
' Dim A As Access.Application
If A.Modules.Count > 0 Then
' first we need be safe that proc 'AddApplicationProperty' already is in one module
addFuncAppProperty A
' now we call injected function
A.Run "AddApplicationProperty", "AppTitle", DB_Text, newTitle
A.Application.RefreshTitleBar
Else
MsgBox "Missing code module in" & vbCrLf & _
"'" & A.Application.DBEngine.Workspaces(0).Databases(0).Name & "'" & vbCrLf & _
"So I could not inject code to set app title"
End If
End Function
' sets a new application title (extras/start/AppTitle..)
Public Function modify_ApplicationTitle_fname(targetDb As String, newTitle As String) As Integer
Dim oAcc As New cAccessCtrl, A As Access.Application
If Not oAcc.Init(targetDb, True, True) Then
MsgBox oAcc.ErrDescription, vbCritical, "ErrorNo. " & oAcc.AccErr
Exit Function
End If
Set A = oAcc.ObjAccApplication
modify_ApplicationTitle_fname = modify_ApplicationTitle(A, newTitle)
End Function
Private Function setCode_FunctionAddApplicationProperty() As String
Dim s As String
s = vbCrLf
s = s & "Public Function AddApplicationProperty(strName As String, varTyp As Variant, varWert As Variant) As Integer" & vbCrLf & _
vbTab & "Dim dbs As Object, prp As Variant" & vbCrLf & _
vbTab & "Const conPropNotFoundError = 3270" & vbCrLf & _
vbTab & "Set dbs = CurrentDb" & vbCrLf & _
vbTab & "On Error GoTo AddApplicationProperty_Err" & vbCrLf & _
vbTab & "dbs.Properties(strName) = varWert" & vbCrLf & _
vbTab & "AddApplicationProperty = True" & vbCrLf & _
"AddApplicationProperty_End:"
s = s & _
vbTab & "Exit Function" & vbCrLf & _
"AddApplicationProperty_Err:"
s = s & _
vbTab & "If Err = conPropNotFoundError Then" & vbCrLf & _
vbTab & vbTab & "Set prp = dbs.CreateProperty(strName, varTyp, varWert)" & vbCrLf & _
vbTab & vbTab & "dbs.Properties.Append prp" & vbCrLf & _
vbTab & vbTab & "Resume" & vbCrLf & _
vbTab & "Else" & vbCrLf & _
vbTab & vbTab & "AddApplicationProperty = False" & vbCrLf & _
vbTab & vbTab & "Resume AddApplicationProperty_End" & vbCrLf & _
vbTab & "End If" & vbCrLf & _
"End Function"
setCode_FunctionAddApplicationProperty = s
End Function
Public Sub test_catalog_functions(fname As String)
Dim i As Integer
Dim cnn As New ADODB.Connection
' when inside Access
' Set cnn = CurrentProject.Connection
' when from VB
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FileExists(fname) Then
MsgBox "Bitte DB-Pfad überprüfen", vbCritical, "DB-Pfad falsch:": Exit Sub
End If
Set objFSO = Nothing
cnn.Mode = adModeShareExclusive
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & fname & ";"
Dim cat As New ADOX.Catalog
cat.ActiveConnection = cnn
' Open the catalog / other way of doing it and: using system db for security purpose
' cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
' "Data Source=.\NorthWind.mdb;User Id=Admin;" & _
' "Password=password;Jet OLEDB:System database=" & _
' "C:\Program Files\Microsoft Office\Office\SYSTEM.MDW"
' ' Print the owner of the Customers table
' Debug.Print cat.GetObjectOwner("Customers", adPermObjTable)
' For i = 0 To cat.Tables.Count - 1
' Debug.Print "tbl: " & cat.Tables(i).Name
' Next i
Dim tbl As New ADOX.Table
Set tbl = cat.Tables("cars_p")
Debug.Print "Properties: " & tbl.Properties.Count
Debug.Print "col_count: " & tbl.Columns.Count
Dim j As Integer, prop As ADOX.Properties, col As ADOX.Column
For j = 0 To tbl.Columns.Count - 1
Set col = tbl.Columns(j)
With col
If .Type = adCurrency Then
Debug.Print "tbl_.name: " & .Name & " >> Type: " & .Type
Debug.Print " Attrib: " & .Attributes
Debug.Print " Def.Size: " & .DefinedSize
Debug.Print " numScale: " & .NumericScale
Debug.Print " Precsion: " & .Precision
' Stop
End If
End With
' For i = 0 To tbl.Columns(j).Properties.Count - 1
' Set prop = tbl.Columns(j).Properties(i)
' Debug.Print "tbl_col.prop.name: " & prop.Name & " > '" & prop.Value & "'"
' Next i
Next j
End Sub
Public Function update_test(targetDb As String) As Integer
Dim oAcc As New cAccessCtrl, A As Access.Application
Dim m As Module, i As Integer
If Not oAcc.Init(targetDb, True, True) Then
MsgBox oAcc.ErrDescription, vbCritical, "ErrorNo. " & oAcc.AccErr
Exit Function
End If
Set A = oAcc.ObjAccApplication
A.DoCmd.OpenModule "Modul1", "test"
A.DoCmd.SelectObject acModule, "Modul1", False
Dim f As Access.Form, mdl As Module
Set f = A.CreateForm
' f.Name = "NewTestForm" ' this is a read only property
f.Dirty = False
Set mdl = f.Module
mdl.AddFromString "Public intY As Integer"
End Function
.
- References:
- Update DB table from visual basic script
- From: mcolson
- Update DB table from visual basic script
- Prev by Date: Re: how to 'Sell' Access into the workplace
- Next by Date: Re: Open Form to Specific Record
- Previous by thread: Update DB table from visual basic script
- Next by thread: how to 'Sell' Access into the workplace
- Index(es):
Relevant Pages
|
Loading
