What is wrong with this script?
Option Explicit
Dim objRootDSE, strDNSDomain, adoConnection
Dim strBase, strFilter, strAttributes, strQuery, adoRecordset
Dim dtmStart, dtmEnd, strStart, strEnd
Dim strID, strFirst, strLast, strNTName
dtmEnd = Now()
dtmStart = DateAdd("d", -7, dtmEnd)
strStart = CStr(Year(dtmStart)) _
& Right("0" & CStr(Month(dtmStart)), 2) _
& Right("0" & CStr(Day(dtmStart)), 2) & "000000.0Z"
strEnd = CStr(Year(dtmEnd)) _
& Right("0" & CStr(Month(dtmEnd)), 2) _
& Right("0" & CStr(Day(dtmEnd)), 2) & "235959.0Z"
' Determine DNS domain name.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
' Use ADO to search Active Directory.
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
Set adoRecordset = CreateObject("ADODB.Recordset")
adoRecordset.ActiveConnection = adoConnection
' Search entire domain.
strBase = "<LDAP://" & strDNSDomain & ">"
'For user accounts for people created in the last week
strFilter = "(&(objectCategory=person)(objectClass=user)" _
& "(whenCreated>=" & strStart & ")(whenCreated<=" & strEnd & "))"
' Comma delimited list of attribute values to retrieve.
strAttributes = "employeeID,sn,givenName,sAMAccountName"
' Construct the LDAP query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
' Run the query.
adoRecordset.Source = strQuery
adoRecordset.Open
' Enumerate the resulting recordset.
Do Until adoRecordset.EOF
' Retrieve values.
strID = adoRecordset.Fields("employeeID").Value
strLast = adoRecordset.Fields("sn").Value
strFirst = adoRecordset.Fields("givenName").Value
strNTName = adoRecordset.Fields("sAMAccountName").Value
Wscript.Echo """" & strID & """,""" & strLast & """,""" & strFirst
& """,""" & strNTName & """"
adoRecordset.MoveNext
Loop
' Clean up.
adoRecordset.Close
adoConnection.Close
cscript //nologo test.vbs > users.csv
returns
(53, 1) Microsoft VBScript compilation error: Expected statement
You're missing an underscore line continuation at the end of the first line of this snippet:
Wscript.Echo """" & strID & """,""" & strLast & """,""" & strFirst
& """,""" & strNTName & """"
It should look like this:
Wscript.Echo """" & strID & """,""" & strLast & """,""" & strFirst _
& """,""" & strNTName & """"
Related
I'm trying to create a tool that will import an Excel file data into the SQL Server database. The thing is I get an error
Command Text was not set for the command Object
I guess there's something wrong with my "Do While". I tried first simple insert query no error but it saved in SQL Server as blank.
Private Sub CommandButton1_Click()
Dim SourcePath, DestPath, PMatrixPath, FileExists, x
SourcePath = ThisWorkbook.Worksheets("Config").Cells(2, 2).Value
DestPath = ThisWorkbook.Worksheets("Config").Cells(3, 2).Value
Dim Conn As ADODB.connection
Dim rsSql As New ADODB.Recordset
Dim server_name As String, database_name As String
Dim sqlQuery As String
Dim ShtName As String
Dim rw As Integer
If SourcePath = "" Then
SourcePath = Application.GetOpenFilename _
(Title:="Please choose the Daily APAC file", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If SourcePath = False Then
MsgBox "No Daily RAW data File Selected. Please set the path in Config Tab or select here", vbExclamation, "Sorry!"
Exit Sub
End If
End If
FileExists = Dir(SourcePath)
If FileExists = "" Then
MsgBox "Daily RAW data File doesn't exist in the mentioned path", vbExclamation, "Sorry!"
Exit Sub
End If
With Sheets("Sheet1")
Set Conn = New ADODB.connection
Let server_name = "10.206.88.119\BIWFO"
Let database_name = "TESTDB"
Let UserName = "admin"
Let Password = "pass"
Conn.Open "Provider=SQLOLEDB;Data Source=" + server_name & ";Initial Catalog=TESTDB;" + "Uid=" & UserName + "; Pwd=" & Password + ";"
rw = 2
Do While Not .Range("A" & rw).Value = ""
Sheet1.Range("A2").Value = rw
sqlQuery = "Insert into tbl_MN_Daily_SLA values ('" & .Range("A" & rw).Value & "','" & .Range("B" & rw).Value & "','" & .Range("G" & rw).Value & "','" & .Range("AX" & rw).Value & "','" & .Range("I" & rw).Value & "','" & .Range("AU" & rw).Value & "','" & .Range("AV" & rw).Value & "','" & .Range("J" & rw).Value & "','" & .Range("M" & rw).Value & "','" & CDate(.Range("N" & rw).Value) & "','" & CDate(.Range("S" & rw).Value) & "','" & CDate(.Range("T" & rw).Value) & "','" & .Range("AF" & rw).Value & "','" & .Range("C" & rw).Value & "','" & CDate(.Range("U" & rw).Value) & "','" & .Range("V" & rw).Value & "','" & CDate(.Range("X" & rw).Value) & "','" & CDate(.Range("Y" & rw).Value) & "','" & CDate(.Range("AD" & rw).Value) & "','" & CDate(.Range("AE" & rw).Value) & "','" & .Range("L" & rw).Value & "');"
rw = rw + 1
Loop
Debug.Print sqlQuery
rsSql.CursorLocation = adUseClient
rsSql.Open sqlQuery, Conn, adOpenStatic
Conn.Close
Set Conn = Nothing
End With
End Sub
I am connecting to a SQL table via an Excel VBA script using using SQL Server vs Windows Authentication as we're creating a generic update application to be used by several different users. If I log into SQL Server Management Studio with the generic ID/pswd and SQL Server Authentication, I can successfully insert and delete rows. When I use the VBA script, I receive an error indicating that the INSERT or DELETE permission was denied. The VBA script works successfully against the same table in a different schema, but fails going against this schema. I am assuming it's something in the SQL environment, as it seems like it's forced to Windows Authentication regardless of how I make the connection. Any help would be greatly appreciated.
Updates:
Thanks for the responses. I hope this additional information helps. We are on SQL Server 15.04102.2, and I am using SQL Server Authentication with a generic application ID and PSWD that has update permissions (my individual windows account only has select permissions)
As I indicated in my initial post, if I execute this code against one test environment, the DELETE and INSERT work perfectly. When I execute it against a different environment, the connection is made, but I get the permissions error on the DELETE and INSERT. If I use the exact same credentials and use SQL Server Authentication to go directly to that environment, I can successfully execute the DELETE and INSERT statements.
Here is the error I receive on the DELETE statement. A similar error is received on the INSERT statement if I bypass the delete for a new add.
Error -2147217911 (The DELETE permission was denied on the object
‘BCG_CGS_DETAILS’, database ‘xxxxxxcustom’, schema ‘dbo’.) in
procedure Export CGS to SQL. sSQL = delete dbo.BCG_CGS_DETAILS where
[CGSNUM]= ‘CGS-xxxxx’ AND [PDPD_ID]= ‘xxxxx’ AND EFF_DT=’7/1/2021’
Here is the code I am executing.
Sub Export_CGS_to_SQL()
Dim cnn
Dim rst
Dim sSQL As String
Dim iRow As Integer
Dim sLINE, sCategory, sBCBSNC_Medical_Policy, sBCBSNC_Standard_Provisions As String
Dim sIn_Network_VALUE, sIn_Network_Type_of_payment, sIn_Network_Detail As String
Dim sOut_of_Network_VALUE, sOut_of_Network_Type_of_payment, sOut_of_Network_Detail As String
Dim sCustomized, sCGSNUM, sPDPD_ID, sEFF_DT As String
Dim lLastrow As Long
Dim sServer, sTable, sDatabase, sConnection As String
On Error GoTo errHandler
With Sheets("CGS Data")
sCGSNUM = .Cells(2, 12)
sPDPD_ID = .Cells(2, 13)
sEFF_DT = .Cells(2, 14)
If sCGSNUM = "" Or sPDPD_ID = "0" Or sEFF_DT = "" Then
MsgBox "One or more required fields is blank. Please make sure that the Product ID and Effective date are set correctly on the MISC tab, and that the CGS Number exists for row A06c on the Client Profile tab"
Exit Sub
End If
lLastrow = Cells(Rows.Count, 1).End(xlUp).Row
sServer = Worksheets("MACRO_DATA").Range("B6").Value
sTable = Worksheets("MACRO_DATA").Range("B7").Value
sDatabase = Worksheets("MACRO_DATA").Range("B8").Value
sConnection = Worksheets("MACRO_DATA").Range("F5").Value
'Create a new Connection object
Set cnn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
If cnn.State <> 1 Then
sSQL = "Provider=SQLOLEDB;Data Source=" & sServer & "; Initial Catalog=" & sDatabase & ";" & sConnection & "; Trusted_Connection=yes"
cnn.Open (sSQL)
End If
Set rst.ActiveConnection = cnn
sSQL = "delete " & sTable & " where [CGSNUM]= '" & sCGSNUM & "' AND [PDPD_ID]= '" & sPDPD_ID & "' AND EFF_DT= '" & sEFF_DT & "'"
cnn.Execute sSQL
For iRow = 2 To lLastrow
sLINE = .Cells(iRow, 1)
If sLINE <> "" Then
sCategory = .Cells(iRow, 2)
sBCBSNC_Medical_Policy = .Cells(iRow, 3)
sBCBSNC_Standard_Provisions = .Cells(iRow, 4)
sIn_Network_VALUE = .Cells(iRow, 5)
sIn_Network_Type_of_payment = .Cells(iRow, 6)
sIn_Network_Detail = .Cells(iRow, 7)
sOut_of_Network_VALUE = .Cells(iRow, 8)
sOut_of_Network_Type_of_payment = .Cells(iRow, 9)
sOut_of_Network_Detail = .Cells(iRow, 10)
sCustomized = .Cells(iRow, 11)
sCGSNUM = .Cells(iRow, 12)
sPDPD_ID = .Cells(iRow, 13)
sEFF_DT = .Cells(iRow, 14)
'insert row into sDatabase
sSQL = "insert into " & sTable & "([LINE],[Category],[BCBSNC Medical Policy],[BCBSNC Standard Provisions],[In-Network_VALUE]," _
& "[In-Network_Type of payment],[In-Network Detail],[Out-of-Network_VALUE],[Out-of-Network_Type of payment],[Out-of-Network_Detail]," _
& "[Customized],[CGSNUM],[PDPD_ID],[EFF_DT])" _
& "values ('" & sLINE & "', '" & sCategory & "', '" & sBCBSNC_Medical_Policy & "', '" & sBCBSNC_Standard_Provisions & "', '" _
& sIn_Network_VALUE & "', '" & sIn_Network_Type_of_payment & "', '" & sIn_Network_Detail & "', '" & sOut_of_Network_VALUE & "', '" _
& sOut_of_Network_Type_of_payment & "', '" & sOut_of_Network_Detail & "', '" & sCustomized & "', '" & sCGSNUM & "', '" _
& sPDPD_ID & "', '" & sEFF_DT & "')"
cnn.Execute sSQL
End If
Next iRow
MsgBox "CGS Data successfully exported to " & sTable, vbInformation
cnn.Close
Set cnn = Nothing
End With
Exit Sub
errHandler:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export CGS to SQL. sSQL = " & sSQL
cnn.Close
Set cnn = Nothing
End Sub
I am trying to send email to multiple addresses, through a array on the .To, was reading the email addresses in range P2:Z2, and the code wasn't working, i changed the range to M1:M10, and the code worked just fine, what the change that i have to make to function in a (1, 10) arrangement?
Sub EnvioEmail()
Range("B4:K34").ExportAsFixedFormat xlTypePDF, Sheets("Aviso").TextBox1.Text & "\" & Sheets("Aviso").Range("P3").Value
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim EmailTo As String
EmailTo = Join(Application.Transpose(Sheets("Aviso").Range("M1:M10").Value), ";")
With OutMail
.To = EmailTo
.CC = ""
.BCC = ""
.Subject = "Aviso de Cobrança de Aluguel e Encargos " & Sheets("Aviso").Range("P3").Text
.Body = "Prezados, " & _
vbNewLine & vbNewLine & _
"Segue em anexo o aviso de cobrança." & _
vbNewLine & vbNewLine & _
"Atenciosamente, "
.Attachments.Add Sheets("Aviso").TextBox1.Text & "\" & Sheets("Aviso").Range("P3").Value & ".pdf"
.Display
End With
End Sub
I have the same line Repeating many times with small changes. i like to shorten it by using an array of objects
For example, instead of this code:
StartUpdateStr = "Update tblAfterSale SET "
EndUpdateStr = " WHERE IDAfterSale = "
IDAfterSale = Me.lblIDAfterSale.Caption
db.Execute StartUpdateStr & "Data1 = " & Me.Lable1.Caption & EndUpdateStr & IDAfterSale
db.Execute StartUpdateStr & "Data2 = " & Me.Lable2.Caption & EndUpdateStr & IDAfterSale
db.Execute StartUpdateStr & "Data3 = " & Me.Lable3.Caption & EndUpdateStr & IDAfterSale
db.Close
I'm looking for something like this:
Const dCaption = "Me.Lable1.Caption,Me.Lable2.Caption,Me.Lable3.Caption"
Public d(2) As Integer
Public Sub MyMacro()
Dim vntTemp As Variant
Dim intIndex As Integer
vntTemp = Split(lCaption, "d")
For intIndex = 0 To 2
db.Execute StartUpdateStr & "Data"& intIndex & " = " & d(intIndex) & EndUpdateStr & IDAfterSale
Next
End Sub
Can someone write me the right syntax?
Thank you
You can simply access the labels by name with Me("Label" & i)
For intIndex = 0 To 2
db.Execute StartUpdateStr & "Data" & intIndex & " = " _
& Me("Label" & (intIndex + 1)).Caption _
& EndUpdateStr & IDAfterSale
Next
I suppose you will be adding many labels in future. So can you use the below code
Private Sub PrintAllLabel()
For Each ctl In Me.Controls
If TypeName(ctl) = "Label" Then
db.Execute StartUpdateStr & "Data" & intIndex & " = " _
& ctl.Caption _
& EndUpdateStr & IDAfterSale
End If
Next ctl
End Sub
Ok my problem here is that I'm getting a Variable is undefined: 'objObject' error at line 39 char 4. All is good if I remove lines 39-46 but the purpose of the code is to reformat the output from echoing the object which looks like this z:\\\\BAIBOA\\test.txt and change it into a string that looks like this z:\BAIBOA\test.txt to be used later in the code. This code has been edited from another source so maybe I'm not fully understanding what's going on. Any help would be greatly appreciated.
Option Explicit
Dim arrFolders, strComputer, objWMIService, strFolder, strCommand
Dim i, strQuery, strNewFile, arrNewFile, strFilePath, strTempFilePath
Dim colMonitoredEvents, strQueryFolder
arrFolders = Array("Z:\\\\test1", "Z:\\\\test2", "Z:\\\\test2")
strComputer = "."
'strQueryFolder = Replace(strFolder, "\", "\\\\")
Set objWMIService = GetObject("winmgmts:\\" & strComputer _
& "\root\CIMV2")
'Loop through the array of folders setting up the monitor for Each
i = 0
For Each strFolder In arrFolders
'Create the event sink
strCommand = "Set EventSink" & i & " = WScript.CreateObject" & _
"(""WbemScripting.SWbemSink"", ""SINK" & i & "_"")"
ExecuteGlobal strCommand
'Setup Notification
strQuery = "SELECT * FROM __InstanceCreationEvent WITHIN 10 " & _
"WHERE Targetinstance ISA 'CIM_DirectoryContainsFile'" & _
" and TargetInstance.GroupComponent = " & _
"'Win32_Directory.Name=""" & strFolder & """'"
strCommand = "objWMIservice.ExecNotificationQueryAsync EventSink" & _
i & ", strQuery"
ExecuteGlobal strCommand
'Create the OnObjectReady Sub
strCommand = "Sub SINK" & i & "_OnObjectReady(objObject, " & _
"objAsyncContext)" & VbCrLf & vbTab & _
"Wscript.Echo objObject.TargetInstance.PartComponent" & _
VbCrLf & "End Sub"
'WScript.Echo strCommand
ExecuteGlobal strCommand
i = i + 1
---> Line 39 Set objLatestEvent = objObject.TargetInstance.PartComponent
strNewFile = objLatestEvent.TargetInstance.PartComponent
arrNewFile = Split(strNewFile, "=")
strFilePath = arrNewFile(1)
strFilePath = Replace(strFilePath, "\\", "\")
strFilePath = Replace(strFilePath, Chr(34), "")
strFileName = Replace(strFilePath, strFolder, "")
'strTempFilePath = WScript.CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2) & "\TEMP.M4A"
Wscript.Echo strFilePath
Next
WScript.Echo "Waiting for events..."
i = 0
While (True)
Wscript.Sleep(1000)
Wend
Ok Ive came up with a solution for the output but now im stuck getting the script to increment correctly and will only goto the next folder if the first folder gets a file. What i need is for it to scan the array for new files not 1 by 1. :( any suggestions
Option Explicit
Dim arrFolders, strComputer, objWMIService, strFolder, strCommand
Dim i, strQuery, strNewFile, arrNewFile, strFilePath, strTempFilePath
Dim colMonitoredEvents, strQueryFolder, objObject, objLatestEvent
Dim strFileName
arrFolders = Array("Z:\\\\test1", "Z:\\\\test2", "Z:\\\\test2")
strComputer = "."
i = 0
For Each strFolder In arrFolders
'trQueryFolder = Replace(strFolder, "\", "\\\\")
strQueryFolder = strFolder
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colMonitoredEvents = objWMIService.ExecNotificationQuery ("SELECT * FROM __InstanceCreationEvent WITHIN 10 " & " WHERE Targetinstance ISA 'CIM_DirectoryContainsFile' and TargetInstance.GroupComponent='Win32_Directory.Name=""" & strQueryFolder & """'")
Wscript.Echo strQueryFolder
'Do
Set objLatestEvent = colMonitoredEvents.NextEvent
strNewFile = objLatestEvent.TargetInstance.PartComponent
arrNewFile = Split(strNewFile, "=")
strFilePath = arrNewFile(1)
strFilePath = Replace(strFilePath, "\\", "\")
strFilePath = Replace(strFilePath, Chr(34), "")
strFileName = Replace(strFilePath, strFolder, "")
strTempFilePath = WScript.CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2) & "\TEMP.M4A"
' DO THE OPERATION STUFF
' ...
'Wscript.Echo objLatestEvent.TargetInstance.PartComponent
Wscript.Echo strFilePath
' If strFileName = strQueryFolder then i = i + 1 Else
'Loop
i = i + 1
Next
'WScript.Echo "Waiting for events..."
i = 0
While (True)
Wscript.Sleep(1000)
Wend