I'm trying to run the below-mentioned code in VB(Excel Macro) but I'm stuck with an error that pops up on running saying "Automation Error".
strComputer = "."
Set objNetwork = CreateObject("Wscript.Network")
Set fs = CreateObject("Scripting.FileSystemObject")
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colFiles = objWMIService.ExecQuery _
("ASSOCIATORS OF {Win32_Directory.Name='U:\'} Where " _
& "ResultClass = CIM_DataFile")
For Each objFile In colFiles
if objFile.FileName = "ml_*" Then
destinationPROD = "X:\ABC\" & objFile.FileName & "." & objFile.Extension
objFile.Copy(destinationPROD)
objFile.delete
else
destinationPROD = "X:\PQR\" & objFile.FileName & "." & objFile.Extension
objFile.Copy(destinationPROD)
objFile.delete
End If
Next
You just need another slash after "winmgmts:\" :)
It should be:Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
It might be a rights problem. Test it using a local disk. Make sure that all required directories exist.
Related
When I am placing the code Excel file in a folder/directory which does not have any space in it the naming conventions than it is working fine and firing the Web-Service. But when I place the code Excel file in a folder which has space in it's naming convention, I am getting a run-time error:
'-2147024894 (80070002).
Please help
Sub InvokShellScript1()
Dim sApp As String
Dim var As Integer
sApp = ThisWorkbook.Path & "\protected\WSInvoke.bat " & ThisWorkbook.Path & "\protected\Refresh.txt " & ThisWorkbook.Path
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
var = objShell.Run(sApp, 0, True)
End Sub
You need quotes around the paths to be able to handle spaces. Try either of these:
sApp = Chr$(34) & ThisWorkbook.Path & "\protected\WSInvoke.bat" & Chr$(34) & " " & Chr$(34) & ThisWorkbook.Path & "\protected\Refresh.txt" & Chr$(34) & " " & Chr$(34) & ThisWorkbook.Path & Chr$(34)
or if Chr() doesn't work:
sApp = """" & ThisWorkbook.Path & "\protected\WSInvoke.bat"" """ & ThisWorkbook.Path & "\protected\Refresh.txt"" """ & ThisWorkbook.Path & """"
Is it possible to list all the open applications in debug.print?
I tried the below code which doesn't work.
Dim app As Application
For Each app In Windows.Applications
Debug.Print app.Name
Next app
Try something like this.
Dim strComputer As String
Dim objWMIService As Variant
Dim colItems As Variant
Dim objItem As Variant
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", , 48)
For Each objItem In colItems
Debug.Print objItem.ProcessId & " " & objItem.Name & " " & objItem.Caption & " " & objItem.CommandLine & " " & objItem.ExecutablePath
Next
I am trying to import and sort data from a large excel report into a new file using Excel 2007 VBA. I have come up with two methods so far for doing this:
Have Excel actually open the file (code below), gather all data into arrays and output the arrays onto new sheets in the same file and save/close it.
Public Sub GetData()
Dim FilePath As String
FilePath = "D:\File_Test.xlsx"
Workbooks.OpenText Filename:=FilePath, FieldInfo:=Array(Array(2, 2))
ActiveWorkbook.Sheets(1).Select
End Sub
Use ADO to get all data out of the closed workbook, import the whole datasheet into an array (code below) and sort data from there and then output data into a new workbook and save/close that.
Private Sub PopArray() 'Uses ADO to populate an array that will be used to sort data
Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset
Dim Getvalue, SourceRange, SourceFile, dbConnectionString As String
SourceFile = "D:\File_Test.xlsx"
SourceRange = "B1:Z180000"
dbConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=No"";"
Set dbConnection = New ADODB.Connection
dbConnection.Open dbConnectionString 'open the database connection
Set rs = dbConnection.Execute("SELECT * FROM [" & SourceRange & "]")
Arr = rs.GetRows
UpBound = UBound(Arr, 2)
rs.Close
End Sub
The test file used has about 65000 records to sort through (about a third of what I will end up using it for). I was kind of disappointed when the ADO version only performed marginally better than the open worksheet (~44 seconds vs ~40 seconds run time). I was wondering if there is some way to improve the ADO import method (or a completely different method - ExecuteExcel4Macro maybe? - if there is one) that would boost my speed. The only thing I could think of was that I am using "B1:Z180000" as my SourceRange as a maximum range that is then truncated by setting Arr = rs.GetRows to accurately reflect the total number of records. If that is what is causing the slow down, I'm not sure how I would go about finding how many rows are in the sheet.
Edit - I am using Range("A1:A" & i) = (Array) to insert data into the new worksheet.
This answer might not be what you are looking for but I still felt compelled to post it based on your side note [...] or a completely different method ]...].
Here, I am working with files of 200MB (and more) each which are merely text files including delimiters. I do not load them into Excel anymore. I also had the problem that Excel was too slow and needs to load the entire file. Yet, Excel is very fast at opening these files using the Open method:
Open strFileNameAndPath For Input Access Read Lock Read As #intPointer
In this case Excel is not loading the entire file but merely reading it line by line. So, Excel can already process the data (forward it) and then grab the next line of data. Like this Excel does not neet the memory to load 200MB.
With this method I am then loading the data in a locally installed SQL which transfers the data directly to our DWH (also SQL). To speed up the transfer using the above mething and getting the data fast into the SQL server I am transferring the data in chunks of 1000 rows each. The string variable in Excel can hold up to 2 billion characters. So, there is not problem there.
One might wonder why I am not simply using SSIS if I am already using a local installation of SQL. Yet, the problem is that I am not the one loading all these files anymore. Using Excel to generate this "import tool" allowed me to forward these tools to others, who are now uploading all these files for me. Giving all of them access to SSIS was not an option nor the possibility of using a destined network drive where one could place these files and SSIS would automatically load them (ever 10+ minutes or so).
In the end my code looks something like this.
Set conRCServer = New ADODB.Connection
conRCServer.ConnectionString = "PROVIDER=SQLOLEDB; " _
& "DATA SOURCE=" & Ref.Range("C2").Value2 & ";" _
& "INITIAL CATALOG=" & Ref.Range("C4").Value & ";" _
& "Integrated Security=SSPI "
On Error GoTo SQL_ConnectionError
conRCServer.Open
On Error GoTo 0
'Save the name of the current file
strCurrentFile = ActiveWorkbook.Name
'Prepare a dialog box for the user to pick a file and show it
' ...if no file has been selected then exit
' ...otherwise parse the selection into it's path and the name of the file
Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Extracts", "*.csv")
Application.FileDialog(msoFileDialogOpen).Title = "Select ONE Extract to import..."
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show
If intChoice <> 0 Then
strFileToPatch = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
Else
Exit Sub
End If
'Open the Extract for import and close it afterwards
intPointer = FreeFile()
Open strFileNameAndPath For Input Access Read Lock Read As #intPointer
intCounter = 0
strSQL = vbNullString
Do Until EOF(intPointer)
Line Input #intPointer, strLine
If Left(strLine, 4) = """###" Then Exit Sub
'*********************************************************************
'** Starting a new SQL command
'*********************************************************************
If intCounter = 0 Then
Set rstResult = New ADODB.Recordset
strSQL = "set nocount on; "
strSQL = strSQL & "insert into dbo.tblTMP "
strSQL = strSQL & "values "
End If
'*********************************************************************
'** Transcribe the current line into SQL
'*********************************************************************
varArray = Split(strLine, ",")
strSQL = strSQL & " (" & varArray(0) & ", " & varArray(1) & ", N'" & varArray(2) & "', "
strSQL = strSQL & " N'" & varArray(3) & "', N'" & varArray(4) & "', N'" & varArray(5) & "', "
strSQL = strSQL & " N'" & varArray(6) & "', " & varArray(8) & ", N'" & varArray(9) & "', "
strSQL = strSQL & " N'" & varArray(10) & "', N'" & varArray(11) & "', N'" & varArray(12) & "', "
strSQL = strSQL & " N'" & varArray(13) & "', N'" & varArray(14) & "', N'" & varArray(15) & "' ), "
'*********************************************************************
'** Execute the SQL command in bulks of 1.000
'*********************************************************************
If intCounter >= 1000 Then
strSQL = Mid(strSQL, 1, Len(strSQL) - 2)
rstResult.ActiveConnection = conRCServer
On Error GoTo SQL_StatementError
rstResult.Open strSQL
On Error GoTo 0
If Not rstResult.EOF And Not rstResult.BOF Then
strErrorMessage = "The server returned the following error message(s):" & Chr(10)
While Not rstResult.EOF And Not rstResult.BOF
strErrorMessage = Chr(10) & strErrorMessage & rstResult.Fields(0).Value
rstResult.MoveNext
Wend
MsgBox strErrorMessage & Chr(10) & Chr(10) & "Aborting..."
Exit Sub
End If
End If
intCounter = intCounter + 1
Loop
Close intPointer
Set rstResult = Nothing
Exit Sub
SQL_ConnectionError:
Y = MsgBox("Couldn't connect to the server. Please make sure that you have a working internet connection. " & _
"Do you want me to prepare an error-email?", 52, "Problems connecting to Server...")
If Y = 6 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Ref.Range("C7").Value2
.CC = Ref.Range("C8").Value2
.Subject = "Problems connecting to database '" & Ref.Range("C4").Value & "' on server '" & Ref.Range("C2").Value & "'"
.HTMLBody = "<span style=""font-size:10px"">---Automatically generated Error-Email---" & _
"</span><br><br>Error report from the file '" & _
"<span style=""color:blue"">" & ActiveWorkbook.Name & _
"</span>' located and saved on '<span style=""color:blue"">" & _
ActiveWorkbook.Path & "</span>'.<br>" & _
"Excel is not able to establish a connection to the server. Technical data to follow." & "<br><br>" & _
"Computer Name: <span style=""color:green;"">" & Environ("COMPUTERNAME") & "</span><br>" & _
"Logged in as: <span style=""color:green;"">" & Environ("USERDOMAIN") & "/" & Environ("USERNAME") & "</span><br>" & _
"Domain Server: <span style=""color:green;"">" & Environ("LOGONSERVER") & "</span><br>" & _
"User DNS Domain: <span style=""color:green;"">" & Environ("USERDNSDOMAIN") & "</span><br>" & _
"Operating System: <span style=""color:green;"">" & Environ("OS") & "</span><br>" & _
"Excel Version: <span style=""color:green;"">" & Application.Version & "</span><br>" & _
"<br><span style=""font-size:10px""><br>" & _
"<br><br>---Automatically generated Error-Email---"
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
Exit Sub
SQL_StatementError:
Y = MsgBox("There seems to be a problem with the SQL Syntax in the programming. " & _
"May I send an error-email to development team?", 52, "Problems with the coding...")
If Y = 6 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Ref.Range("C8").Value2
'.CC = ""
.Subject = "Problems with the SQL Syntax in file '" & ActiveWorkbook.Name & "'."
.HTMLBody = "<span style=""font-size:10px"">" & _
"---Automatically generated Error-Email---" & _
"</span><br><br>" & _
"Error report from the file '" & _
"<span style=""color:blue"">" & _
ActiveWorkbook.Name & _
"</span>" & _
"' located and saved on '" & _
"<span style=""color:blue"">" & _
ActiveWorkbook.Path & _
"</span>" & _
"'.<br>" & _
"It seems that there is a problem with the SQL-Code within trying to upload an extract to the server." & _
"SQL-Code causing the problems:" & _
"<br><br><span style=""color:green;"">" & _
strSQL & _
"</span><br><br><span style=""font-size:10px"">" & _
"---Automatically generated Error-Email---"
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
Exit Sub
End Sub
i think that #Mr. Mascaro is right the easiest way to past your data from a Recordset into a spreadsheet is:
Private Sub PopArray()
.....
Set rs = dbConnection.Execute("SELECT * FROM [" & SourceRange & "]")
'' This is faster
Range("A1").CopyFromRecordset rs
''Arr = rs.GetRows
End Sub
but if you still want to use Arrays you could try this:
Sub ArrayTest
'' Array for Test
Dim aSingleArray As Variant
Dim aMultiArray as Variant
'' Set values
aSingleArray = Array("A","B","C","D","E")
aMultiArray = Array(aSingleArray, aSingleArray)
'' You can drop data from the Array using 'Resize'
'' Btw, your Array must be transpose to use this :P
Range("A1").Resize( _
UBound(aMultiArray(0), 1) + 1, _
UBound(aMultiArray, 1) + 1) = Application.Transpose(aMultiArray)
End Sub
I need help with a VBS script that produces an Excel sheet with specific user information.
It works... Sort of. The problem is that it seems to recycle information producing inaccurate results. Anybody know how I would go about making the script leave areas in the Excel document blank when no information is available? I know it's possible, just need a nudge in the right direction.
Thank you!
On Error Resume Next
Dim FSO
Dim objStream
Const TriStateFalse = 0
Const FILE_NAME = "Users.csv"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objStream = FSO.CreateTextFile(FILE_NAME, _
True, TristateFalse)
strSubnetPrefix = "192.168.1."
intBeginSubnet = 1
intEndSubnet = 254
For i = intBeginSubnet To intEndSubnet
strComputer = strSubnetPrefix & i
'strcomputer = inputbox("Enter Computer Name or IP")
if strcomputer = "" then
wscript.quit
else
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
("select * from Win32_PingStatus where address = '" & strcomputer & "'")
For Each objStatus in objPing
If IsNull(objStatus.StatusCode) or objStatus.StatusCode<>0 Then
'request timed out
'msgbox(strcomputer & " did not reply" & vbcrlf & vbcrlf & _
'"Please check the name and try again")
else
set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & _
strComputer & "\root\cimv2")
Set colSettings = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")
For Each objComputer in colSettings
objStream.WriteLine objComputer.name & "," & objcomputer.username & "," & objcomputer.domain _
& "," & strcomputer
'msgbox("System Name: " & objComputer.Name & vbcrlf & "User Logged in : " & _
'objcomputer.username & vbcrlf & "Domain: " & objComputer.Domain)
Next
end if
next
end if
Next
Msgbox("Done Collecting")
set objwmiservice = nothing
set colsettings = nothing
set objping = nothing
You use the EVIL global On Error Resume Next. That means: all errors are ignored/hidden and the script continues (more or less happily) in a for all practical purposes undefined state. Demo script:
Option Explicit
Dim a : a = Array(1,0,2)
Bad a
Good a
Sub Bad(a)
Dim i, n
On Error Resume Next
For i = 0 To UBound(a)
n = 4712 / a(i)
WScript.Echo "Bad", i, a(i), n
Next
End Sub
Sub Good(a)
Dim i, n
For i = 0 To UBound(a)
On Error Resume Next
n = 4712 / a(i)
If Err.Number Then n = "value to use in case of error"
On Error GoTo 0
WScript.Echo "Good", i, a(i), n
Next
End Sub
output:
cscript oern.vbs
Bad 0 1 4712
Bad 1 0 4712 <--- assignment failed, 'old' value of n retained, no clue about problem
Bad 2 2 2356
Good 0 1 4712
Good 1 0 value to use in case of error
Good 2 2 2356
The strictly local OERN makes sure that the specific problem (division by zero, ping failure) is dealt with, and all other exceptions are reported, so the program can be improved.
further food for thought
Your WMI call variables need to be reset to nothing before you set them again. This script should work better.
On Error Resume Next
Dim FSO
Dim objStream
Const TriStateFalse = 0
Const FILE_NAME = "Users.csv"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objStream = FSO.CreateTextFile(FILE_NAME, _
True, TristateFalse)
strSubnetPrefix = "192.168.1."
intBeginSubnet = 1
intEndSubnet = 254
For i = intBeginSubnet To intEndSubnet
strComputer = strSubnetPrefix & i
'strcomputer = inputbox("Enter Computer Name or IP")
if strcomputer = "" then
wscript.quit
else
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
("select * from Win32_PingStatus where address = '" & strcomputer & "'")
For Each objStatus in objPing
If IsNull(objStatus.StatusCode) or objStatus.StatusCode<>0 Then
'request timed out
'msgbox(strcomputer & " did not reply" & vbcrlf & vbcrlf & _
'"Please check the name and try again")
else
set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & _
strComputer & "\root\cimv2")
Set colSettings = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")
For Each objComputer in colSettings
objStream.WriteLine objComputer.name & "," & objcomputer.username & "," & objcomputer.domain _
& "," & strcomputer
'msgbox("System Name: " & objComputer.Name & vbcrlf & "User Logged in : " & _
'objcomputer.username & vbcrlf & "Domain: " & objComputer.Domain)
Next
set objwmiservice = nothing
set colsettings = nothing
end if
next
end if
set objping = nothing
Next
Msgbox("Done Collecting")
I obtained this script from another site, and attempted to modify it to search more than two drives, specifically I wanted it to search almost every drive possible, but as soon as i add a third drive letter the script does not work.
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colFiles = objWMIService.ExecQuery _
("Select * from CIM_DataFile Where Extension = 'mdb' AND (Drive = 'B:' OR Drive = 'C:' OR Drive = 'D:')")
' If colFiles.Count = 0 Then
' Wscript.Quit
' End If
Set objTextFile = wshfso.CreateTextFile("c:\temp\" & vComputer & ".txt " , True)
For Each objFile in colFiles
objTextFile.Write(objFile.Drive & objFile.Path & "")
objTextFile.Write(objFile.FileName & "." & objFile.Extension & ", Size ")
objTextFile.Write(objFile.FileSize /1024 & "kb" & vbCrLf)
Next
You've got 2 variables, "vComputer" and "strComputer".