I want to run a vbs from a Visual Basic application and return the string back to the vb app. Google isn't hitting on much. Here is the vbs I want to run, and I want to pass the "ou" information back to the Visual Basic application as a string.
OPTION EXPLICIT
DIM objNetwork
DIM computerName
DIM ou
' Get the computerName of PC
set objNetwork = createobject("Wscript.Network")
'computerName = objNetwork.ComputerName
computername = Inputbox("Enter the network name of the PC to find :")
' Call function to find OU from computer name
ou = getOUByComputerName(computerName)
IF ou = "" THEN ou = "Not Found"
wscript.echo ou
function getOUByComputerName(byval computerName)
' *** Function to find ou/container of computer object from computer name ***
DIM namingContext, ldapFilter, ou
DIM cn, cmd, rs
DIM objRootDSE
' Bind to the RootDSE to get the default naming context for
' the domain. e.g. dc=HCHS,dc=co,dc=uk
set objRootDSE = getobject("LDAP://RootDSE")
namingContext = objRootDSE.Get("defaultNamingContext")
set objRootDSE = nothing
' Construct an ldap filter to search for a computer object
' anywhere in the domain with a name of the value specified.
ldapFilter = "<LDAP://" & namingContext & _
">;(&(objectCategory=Computer)(name=" & computerName & "))" & _
";distinguishedName;subtree"
' Standard ADO code to query database
set cn = createobject("ADODB.Connection")
set cmd = createobject("ADODB.Command")
cn.open "Provider=ADsDSOObject;"
cmd.activeconnection = cn
cmd.commandtext = ldapFilter
set rs = cmd.execute
if rs.eof <> true and rs.bof <> true then
ou = rs(0)
' Convert distinguished name into OU.
' e.g. cn=CLIENT01,OU=HCHS_Computers,dc=HCHS,dc=co,dc=uk
' to: OU=HCHS_Computers,dc=HCHS,dc=co,dc=uk
ou = mid(ou,instr(ou,",")+1,len(ou)-instr(ou,","))
getOUByComputerName = ou
end if
rs.close
cn.close
end function
Have you tried the ScriptControl?
See here:
http://msdn.microsoft.com/en-us/library/aa227413(v=vs.60)
http://support.microsoft.com/kb/184740
http://support.microsoft.com/kb/184739
http://www.techrepublic.com/article/make-your-vb-apps-scriptable-with-the-microsoft-windows-script-control/1045808
Related
I'm doing some development work and need to see what data is stored in Active Directory in order to figure out which fields are being used and may contain information that will be useful. I have a method of pulling all of the mandatory property field names, and of pulling the data with LDAP if I know what the field names are, but what I can't figure out is how to do it dynamically. Here's my code:
Function LDAPdump()
Dim objSysInfo As Object
Dim objSchema As Object
Dim objRecordset As Object
Dim objConnection As Object
Dim objCommand As Object
Dim objUser As Object
Dim objLUser As Object
Dim dname As String
Dim DLoc As Integer
Dim ADaddress As String
Set objSysInfo = CreateObject("ADSystemInfo")
Set objSchema = GetObject("LDAP://schema/user")
Set objUser = GetObject("LDAP://" & objSysInfo.UserName)
dname = objUser.distinguishedName
DLoc = InStr(dname, "DC=")
ADaddress = Right(dname, Len(dname) - DLoc + 1)
Const ADS_SCOPE_SUBTREE = 2
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
objCommand.CommandText = "SELECT * FROM 'LDAP://" & ADaddress & "' WHERE objectCategory='user' AND cn='" & objUser.CN & "'"
Set objRecordset = objCommand.Execute
If objRecordset.RecordCount = 0 Then
MsgBox "no data"
Exit Function
End If
Set objLUser = GetObject(objRecordset.Fields("ADsPath").Value)
'print all mandatory property field names
For Each strAttribute In objSchema.MandatoryProperties
Debug.Print strAttribute & ": " & objLUser(CStr(strAttribute)).Value
Next
End Function
The spot that's specifically giving me issues is pulling the objLUser attribute value. For example, when I run this code the first attribute that comes up is cn. If I specifically write Debug.Print strAttribute & ": " & objLUser.cn I get cn: Chaosbydesign back in the immediate window, but when I try to dynamically get it in the For loop, I get back "The directory property cannot be found in the cache." Looking at objUser or objLUser in the Locals window doesn't provide any hints to a solution because it just says <No Variables> when expanded, even though I can go into the immediate window and type in ? objLUser.cn/mail/displayname and get my common name, email and display name back.
I have a workaround for this that involves a bit of shenanigans with a text file and Excel to basically write out the Debug.Print line for every single attribute, so this problem itself isn't a show stopper, more just an annoyance that I'd like to figure out.
I'm in the process of moving all the Lotus sheets a company has to a SQL Server and I am using MS Access tables as an intermediary.
This code has been working fine for sheets that are not named but I've come across about 2300 or so sheets where it's named numb. There are too many files for me to manually change them all.
The error I am getting is:
Run-Time error '-2147217865(80040e37)':
The Microsoft Jet Database engine could not find the object "numb:A1..numb:A8000". Make sure the object exists and that you spell its name and the path name correctly.
Found this site but that hasn't provided the answer
I've seen different options for getting the destination right on an ADOB call ("SELECT * FROM [numb:A1..numb:A8000];" or ("SELECT * FROM [numb$:A1..numb$:A8000];") and those haven't worked.
Here is the functioning code when the sheet isn't named:
Dim rst As DAO.Recordset
Dim rs As DAO.Recordset
Dim LotusCn As Object
Dim rsLotus As Object
'Read WK3 Lotus files
repcode = rs![Code]
Directory = rs![Directory]
Directory = Directory & "NUMDATM.WK3"
Set LotusCn = CreateObject("ADODB.Connection")
Set rsLotus = CreateObject("ADODB.Recordset")
'This creates the objects for the lotus connctions
'below the connection string
LotusCn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Directory & ";" & _
"Extended Properties=Lotus WK3;Persist Security Info=False"
strSQL = "SELECT * FROM [A1..A8000];" 'The SQL to pick the right sections of the lotus file. Picks the Latest Available Date
rsLotus.Open strSQL, LotusCn, adOpenStatic '<<< ***Error occurs here***
If Not (rsLotus.EOF And rsLotus.BOF) Then
FindRecordCount = rsLotus.RecordCount
rsLotus.MoveFirst
Do Until rsLotus.EOF = True
Debug.Print rsLotus.Fields(0).Value
If Len(rsLotus.Fields(0).Value) > 0 Then
rst.AddNew
rst!RegNo = rsLotus.Fields(0).Value
rst.Update
End If
rsLotus.MoveNext
Loop
End If
LotusCn.Close
strSQL = ""
Set rsLotus = Nothing
Set LotusCn = Nothing
Does anyone know how to get named spreadsheets?
I dont know exactly how in Lotus but this was in Excel
Set oRs = oConn.OpenSchema(adSchemaTables) 'get the name of the sheet in Excel
oRs.MoveFirst
With oRs
While Not .EOF
If .fields("TABLE_TYPE") = "TABLE" Then
Debug.Print .fields("TABLE_NAME")
If VBA.Len(.fields("TABLE_NAME")) = 9 Then
WSnameTBL = .fields("TABLE_NAME")
Else
End If
' WSnameTBL = VBA.Replace(WSnameTBL, "$", "", 1, , vbTextCompare)
End If
.MoveNext
Wend
End With
How can I use VBA to get the email address of users on my network based on their Windows user name?
I have a log file that contains the UserName of everyone who launched this Access database. The username was generated from Environ("USERNAME") when they launched the database. I need to send an email to all recent users.
I don't need it to return the current users email address, and I don't need the code to send email.
I was wondering if it was possible using LDAP, but the example I have only works for the current logged in user. Is there another way?
Function GetEmailAddress(Optional strUserName As String = "") As String
' Get user's email address from LDAP
Dim sysInfo As Object
Dim oUser As Object
If strUserName = "" Then
' No name was passed in. Get it for the current user.
strUserName = Environ("USERNAME")
End If
' How I can I use strUserName to get the email address?
' The LDAP query below only works for the current logged in user.
Set sysInfo = CreateObject("ADSystemInfo")
Set oUser = GetObject("LDAP://" & sysInfo.UserName & "")
Debug.Print "Display Name: "; Tab(20); oUser.Get("DisplayName")
Debug.Print "Email Address: "; Tab(20); oUser.Get("mail")
Debug.Print "Computer Name: "; Tab(20); sysInfo.ComputerName
Debug.Print "Site Name: "; Tab(20); sysInfo.SiteName
Debug.Print "Domain DNS Name: "; Tab(20); sysInfo.DomainDNSName
GetEmailAddress = oUser.Get("mail")
Set sysInfo = Nothing
Set oUser = Nothing
End Function
Personally, I use the following function, though there are many possibilities.
Public Function GetMailAddress(strUsername As String) As String
Dim cmd As New ADODB.Command
Dim cn As New ADODB.Connection
Dim rs As ADODB.Recordset
cn.Open "Provider=ADsDSOObject;"
cmd.CommandText = "<LDAP://dc=MyCompany,dc=intranet>;(&(objectCategory=User)(CN=" & strUsername & "));mail;subtree"
cmd.ActiveConnection = cn
Set rs = cmd.Execute
GetMailAddress = rs.Fields(0).Value
End Function
You need to fill in the valid DC values for your LDAP server, of course.
Currently I have the following code that allows me to insert values into specific fields in QuickBooks.
I am trying to add fields from a table into QuickBooks row by row:
See picture ex:
Example:
At the end of each row there is a column for sending off the entries to QuickBooks. How can I modify my code to have this function work?
Public Sub exampleInsert()
Const adOpenStatic = 3
Const adLockOptimistic = 3
Dim oConnection
Dim oRecordset
Dim sMsg
Dim sConnectString
Dim sSQL
sConnectString = "DSN=Quickbooks Data;OLE DB Services=-2;"
sSQL = "Insert into customer (Name, FullName, CompanyName) values ('Testing VB', 'Full Name', 'Test Company Name')"
Set oConnection = CreateObject("ADODB.Connection")
Set oRecordset = CreateObject("ADODB.Recordset")
oConnection.Open sConnectString
oConnection.Execute (sSQL)
sMsg = sMsg & "Record Added"
MsgBox sMsg
Set oRecordset = Nothing
Set oConnection = Nothing
End Sub
UPDATE:
I added:
sConnectString = "DSN=Quickbooks Data;OLE DB Services=-2;"
sSQL = "Insert into customer (Name, CompanyName) Select Num, Description From TestTable"
Set oConnection = CreateObject("ADODB.Connection")
Set oRecordset = CreateObject("ADODB.Recordset")
oConnection.Open sConnectString
oConnection.Execute (sSQL)
sMsg = sMsg & "Record Added"
MsgBox sMsg
But I get the error "Invalid table name: TestTable" how can I get this SQL script to see my Access table?
To add the form's current record values to your queries, you just pull the value (e.g. Me.txtDescription). I would recommend you use the ADODB.Command object, so you can parameterize your SQL and avoid SQL injection:
Option Explicit
Const adOpenStatic As Integer = 3
Const adLockOptimistic As Integer = 3
Const CONNECTION_STRING As String = "DSN=Quickbooks Data;OLE DB Services=-2;"
Private Sub Command10_Click()
Dim cn As ADODB.Connection
Dim cmd As ADODB.Command
Dim param As ADODB.Parameter
Dim sMsg As String
' set up ADODOB connection
Set cn = New ADODB.Connection
cn.Open CONNECTION_STRING
' set up ADODB command object
Set cmd = New ADODB.Command
cmd.ActiveConnection = cn
' note that we're using unnamed parameters,
' with the ? symbol
cmd.CommandText = _
"INSERT INTO customer " & _
"(Name, CompanyName) " & _
"VALUES " & _
"(?, ?)"
' add form values as command parameters
cmd.Parameters.Append cmd.CreateParameter( _
Type:=adVarChar, _
Size:=255, _
value:=Me.txtNumber)
cmd.Parameters.Append cmd.CreateParameter( _
Type:=adVarChar, _
Size:=255, _
value:=Me.txtDescription)
' now that we have the command set up with its params,
' we can just execute it:
cmd.Execute
sMsg = "Record Added"
MsgBox sMsg
Set param = Nothing
Set cmd = Nothing
cn.Close: Set cn = Nothing
End Sub
Of course, you'll have to use the actual names of your textboxes.
Also, please notice a couple of additional modifications I a made to your original code:
I have Option Explicit defined. You may already have this in your code, but if not, you need it. That way, any variables used have to be declared. For more information, see the Microsoft Docs
I moved your ADODB constants outside your sub. Ideally, you'd either use early binding and add the ADODB library reference (so you don't need to define these yourself), or add them in a separate module, so you can use them in any of your forms.
I also added your connection string as a constant outside your sub. Again, this should probably be in a separate module (e.g. modConstants) you can easily refer to from anywhere in your project.
I improved the indentation of your code.
I explicitly added the types for your declarations (Dim sSQL as String rather than just Dim sSQL). Note that if you declare a variable without a type, it defaults to the Variant type, instead of String (which you want). See Microsoft Docs for more information.
I have an Excel file that exports data into Word. It includes a cover page and grabs the user name ("First.Last") and changes it to "First Last" but I also need to include the user's professional title. This information is housed in an Access table. It has a field called Name and a field called Title. The Name field match exactly to User with no duplicates.
I have tried about eight different methods I've found online to grab this value from the table. The table will never happen to be open so I can't use "CurrentDB()".
I just need to be able to reach into the table in a database, grab the "title" value given that the value of the field "Name" is equal to the value of User (user name from the environment - the person using the excel file).
If it helps, I can provide examples of the different chunks of code I've used so far.
User is the username from the environment
tblPickName is the table I am trying to open
Path is the directory and file where the table is located
tblPickName has 2 fields, Name and Title
I need to grab the Title from this table and set it to my variable "Title" as long as Name equals User. Then I can export the username and title to Word along with the rest of the data.
Dim Path As String
Dim User As String
Dim Title As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
User = Environ("UserName")
User = Replace(User, ".", " ")
User = StrConv(User, vbProperCase)
Path = "Directory\Name.mdb"
Set db = DBEngine.OpenDatabase(Path)
Set rs = db.OpenRecordset("SELECT tblPickAnalyst.Title FROM tblPickAnalyst WHERE [Analyst]='" & User & "'")
Title = rs!Title
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
docWord.Bookmarks("AnalystName").Range.Text = User
docWord.Bookmarks("AnalystTitle").Range.Text = Title
Try this:
Public Sub JohnTayloristheBest()
Dim conAccess As ADODB.Connection
Set conAccess = New ADODB.Connection
Dim rdsAccess As ADODB.Recordset
Dim strTitle as String
With conAccess
.ConnectionString = "Data Source= **insert filepath here** "
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Open
End With
With rdsAccess
.Open "SELECT tblPickName.Title FROM tblPickName WHERE tblPickName.Name = '" & Environ("username") & "';", conAccess
If Not .EOF And Not IsNull(.fields(0)) Then
strTitle = .fields(0)
Else
Msgbox "Error: No record in the database for " & Environ("username")
End If
.Close
End With
conAccess.Close: conAccess = Nothing
End Sub
Be sure to select the correct references by doing this: http://msdn.microsoft.com/en-us/library/windows/desktop/ms677497(v=vs.85).aspx
Also, this is my first answer ever written on this site (or any other for that matter), so be kind.
Try this:
Public Function getTitle(name As String)
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = DBEngine.OpenDatabase("E:\Temp\Database.mdb")
Set rs = db.OpenRecordset("SELECT Title FROM tblPickName WHERE Name='" & name & "'")
If rs.RecordCount > 0 Then
getTitle = rs!Title
End If
rs.Close
db.Close
End Function
Ensure read access on table tblPickName (for Administrator)
Here is the final solution. Thank you to everyone who helped!
Dim Path As String
Dim User As String
Dim Title As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
User = Environ("UserName")
User = Replace(User, ".", " ")
User = StrConv(User, vbProperCase)
Path = "Directory\FileName"
Set db = DBEngine.OpenDatabase(Path)
Set rs = db.OpenRecordset("SELECT tblPickAnalyst.Title FROM tblPickAnalyst WHERE [Analyst]='" & User & "'")
Title = rs!Title
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
docWord.Bookmarks("AnalystName").Range.Text = User
docWord.Bookmarks("AnalystTitle").Range.Text = Title