I am trying to create this:
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessList = objWMIService.ExecQuery _
("Select * from Win32_Process Where Name = 'Chrome.exe'")
Set oShell = CreateObject("WScript.Shell")
For Each objProcess in colProcessList
oShell.Run "taskkill /im chrome.exe", , True
Next
Dim iURL
Dim objShell
iURL = "www.google.com.au"
set objShell = CreateObject("Shell.Application")
objShell.ShellExecute "chrome.exe", iURL, "", "", 1
The code works, but if there are too many chrome tabs open, it doesn't close all tabs. There is also sometimes an error message in closing tabs.
One way to do it is opening Chrome in incognito mode so that you don't see the Restore Session error.
Dim objExec, objShell, iURL
Set objShell = CreateObject("WScript.Shell")
Set objExec = objShell.Exec("tasklist /fi " & Chr(34) & "imagename eq chrome.exe" & Chr(34))
If Not InStr(1, objExec.StdOut.ReadAll(), "INFO: No tasks", vbTextCompare) Then
objShell.Run "taskkill /f /t /im chrome.exe", 0, True
End If
iURL = "www.google.com.au"
objShell.Run "chrome.exe -incognito " & iURL
Set objExec = Nothing : Set objShell = Nothing
WScript.Quit
Related
I don't know why I'm getting an error on the Set objShell = statement of this VBS code (it's in an HTML). I'm working on a .HTA launcher for a game named Doom and this VBScript serves to select the game and launch it with some parameters.
Dim pwad, warp, skill, execDoom, execPwad, execWarp, execSkill, rep, fso, file, OpFScript, WScript, objShell
Set objShell = WScript.CreateObject("WScript.Shell")
Set pwad = document.GetElementById("inpFILE")
Set warp = document.GetElementById("inpMAP")
Set skill = document.GetElementById("inpSKILL")
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.OpenTextFile("C:\ZDLRemastered\launcher\ScriptOpFile.txt", 1)
OpFScript = file.ReadAll
Function GetFileDlgEx(sIniDir,sFilter,sTitle)
Set oDlg = CreateObject("WScript.Shell").Exec("mshta.exe & OpFScript")
oDlg.StdIn.Write "var iniDir='" & sIniDir & "';var filter='" & sFilter & "';var title='" & sTitle & "';"
GetFileDlgEx = oDlg.StdOut.ReadAll
End Function
sFilter = "Doom Archive (*.wad)|*.wad|"
sTitle = "Select a Doom IWAD"
rep = GetFileDlgEx(Replace(sIniDir,"\","\\"),sFilter,sTitle)
execDoom = "C:\ZDLRemastered\gzdoom\gzdoom.exe -config C:\ZDLRemastered\gzdoom\gzconfig.ini -iwad "
execPwad = " -file "
execWarp = " -warp "
execSkill = " -skill "
objShell.Run execDoom & Chr(34) & rep & Chr(34) & execPwad & Chr(34) & pwad & Chr(34) & execWarp & Chr(34) & warp & Chr(34) & execSkill & Chr(34) & skill & Chr(34)
This is the error:
necessary object: " -
HTAs run in a different engine than regular VBScript (mshta.exe vs wscript.exe/cscript.exe). The HTA engine does not provide an intrinsic WScript object, hence WScript.CreateObject() or WScript.Sleep() or WScript.Quit() won't work.
That intrinsic object isn't required for creating objects, though, since VBScript also has a global function CreateObject() (which is not the same as WScript.CreateObject()).
Change this:
Set objShell = WScript.CreateObject("WScript.Shell")
into this:
Set objShell = CreateObject("WScript.Shell")
and the problem will disappear.
This question already has answers here:
How to keep formats when I copy a range from Excel to outlook
(2 answers)
Closed 3 years ago.
All,
I have been using the below code to generate an email which compiles a range into an HTML body of an email.
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lastrow As Long
Dim sht As Worksheet
Dim StrBody As String
Set rng = Nothing
Sheets("HTML Loop").Activate 'Change
Set sht = ActiveSheet
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Range
On Error Resume Next
Set rng = sht.Range("A1:A" & lastrow).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If sht.Range("A1").Value = "" Then
Exit Sub
End If
StrBody = "All," & "<br>" & "<br>" & _
"The Robot has completed its daily check of the FX3 Site and has created " & lastrow & " new folder location(s)." & "<br>" & "<br>" & _
"*Please review the files located here:"
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Sean.B#xxx.co.uk"
.CC = ""
.BCC = ""
.Subject = "Daily FX3 Notification Email " & Now()
.HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & "<br>" & "<br>" & "Thanks" & "<br>" & "<br>" & "Gary"
.Display
.Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutA
End sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
The issue I am having is when the email is generated, the strings within the range is cut at 9 Characters long.
The range consists of file paths like the below:
\csdatg09\financial systems\Automation\Pega Projects\Tax\FIN_TAX_GARY\Bristol\TEST TEST 108 EastCott Hill
\csdatg09\financial systems\Automation\Pega Projects\Tax\FIN_TAX_GARY\Exeter\TEST TEST 108 EastCott Hill
I would like to understand why the output is like the screenshot attached.
All, this is a duplicate question the answer I was looking for can be found here:
How to keep formats when I copy a range from Excel to outlook
Specific Code:
TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
'.Cells(1).PasteSpecial xlPasteValues, , False, False
'.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
I am trying to create a vbscript that clears all my browser data in chrome, then closes all chrome windows.
I am having trouble closing word and outlook.
This it the code that works so far and clears chrome and closes the chrome browser:
Set WshShell = CreateObject("WScript.Shell")
set WshShell=WScript.CreateObject("WScript.Shell")
WshShell.run "chrome.exe"
Set WshShell = CreateObject("WScript.Shell")
set WshShell=WScript.CreateObject("WScript.Shell")
WshShell.run "chrome.exe"
WScript.Sleep (1000)
WScript.CreateObject("WScript.Shell").SendKeys("^h")
WScript.Sleep (2000)
WScript.CreateObject("WScript.Shell").SendKeys("{TAB}")
WScript.CreateObject("WScript.Shell").SendKeys("{TAB}")
WScript.CreateObject("WScript.Shell").SendKeys("{TAB}")
WScript.CreateObject("WScript.Shell").SendKeys("{ENTER}")
WScript.Sleep (2000)
WScript.CreateObject("WScript.Shell").SendKeys("{TAB}")
WScript.CreateObject("WScript.Shell").SendKeys("{TAB}")
WScript.CreateObject("WScript.Shell").SendKeys("{TAB}")
WScript.CreateObject("WScript.Shell").SendKeys("{TAB}")
WScript.CreateObject("WScript.Shell").SendKeys("{TAB}")
WScript.CreateObject("WScript.Shell").SendKeys("{TAB}")
WScript.CreateObject("WScript.Shell").SendKeys("{TAB}")
WScript.CreateObject("WScript.Shell").SendKeys("{TAB}")
WScript.CreateObject("WScript.Shell").SendKeys("{TAB}")
WScript.CreateObject("WScript.Shell").SendKeys("{ENTER}")
WshShell.AppActivate("Google Chrome")
WshShell.run "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 8"
WshShell.run "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 2"
WshShell.run "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 1"
WshShell.run "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 16"
WshShell.run "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 32"
WshShell.run "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 255"
Set objExec = Nothing : Set objShell = Nothing
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessList = objWMIService.ExecQuery _
("Select * from Win32_Process Where Name = 'Chrome.exe'")
Set oShell = CreateObject("WScript.Shell")
For Each objProcess in colProcessList
oShell.Run "taskkill /im chrome.exe", , True
Next
Set objShell = CreateObject("WScript.Shell")
Set objExec = objShell.Exec("tasklist /fi " & Chr(34) & "imagename eq chrome.exe" & Chr(34))
If Not InStr(1, objExec.StdOut.ReadAll(), "INFO: No tasks", vbTextCompare) Then
objShell.Run "taskkill /f /t /im chrome.exe", 0, True
End If
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessList = objWMIService.ExecQuery _
("Select * from Win32_Process Where Name = 'notepad.exe'")
For Each objProcess in colProcessList
objProcess.Terminate()
Next
I am trying to close all of the word documents open and save them, basically (control s). I would like all of this to happen in one VBS file so that I can send this to my friends, and they can use it too easily.
I have researched online, but haven't found what I am looking for.
All the websites that I have looked at have either, only show how to close all documents without saving them or have not shown the process in VBS, instead using VBA or another scripting language.
I would appreciate if someone could help me write my script!
:)
Save and close all documents:
'get a handle to the already running Word instance
On Error Resume Next
Set wd = GetObject(, "Word.Application")
On Error Goto 0
If Not IsEmpty(wd) Then
For Each doc In wd.Documents
doc.Save
doc.Close
Next
wd.Quit
End If
For closing all documents without saving change doc.Save to doc.Saved = True. That basically tells Word "this document was already saved, shut up".
I'm having trouble getting a range that is embedded in an email to left align. I've tried several things but the embedded portion still centers in the email. Here is my code, which ironically, works just fine in other spreadsheets. I've tried adding HTML tags, changing the function(s), all to no avail. Any help would be appreciated. This is on W7x64 and Office 2010. In this report I am embedding a pivot table instead of a regular range.
Thanks.
Option Explicit
SalesSub Mail_RegionalRANGE()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
'On Error Resume Next
Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.SentOnBehalfOfName = "SalesAnalytics#company.us"
.Display
.Subject = "Sales Report"
.To = "mike.marshall#company.us"
'.CC =
'.BCC =
'.Attachments.Add "\\filesrv1\department shares\Sales Report\Sales Report.xlsx"
.HTMLBody = "<br>" _
& "Attached is the Sales Report. Please reach out to me with any questions." _
& "<br><br>" _
& "<p align=left>" & fncRangeToHtml("RegAEPctg", "B2:P67") & "<p>" _
& .HTMLBody
.Display
'.Send
End With
Set OutApp = Nothing
Set OutMail = Nothing
End Sub
Private Function fncRangeToHtml( _
strWorksheetName As String, _
strRangeAddress As String) As String
Dim objFilesytem As Object, objTextstream As Object, objShape As Shape
Dim strFilename As String, strTempText As String
Dim blnRangeContainsShapes As Boolean
Set objTextstream = Nothing
Set objFilesytem = Nothing
'Kill strFilename
strFilename = Environ$("temp") & "\" & _
Format(Now, "dd-mm-yy_h-mm-ss") & ".htm"
ThisWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=strFilename, _
Sheet:=strWorksheetName, _
Source:=strRangeAddress, _
HtmlType:=xlHtmlStatic).Publish True
Set objFilesytem = CreateObject("Scripting.FileSystemObject")
Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
strTempText = objTextstream.ReadAll
objTextstream.Close
strTempText = Replace(strTempText, "align=center x:publishsource=", "align=left x:publishsource=")
For Each objShape In Worksheets(strWorksheetName).Shapes
If Not Intersect(objShape.TopLeftCell, Worksheets( _
strWorksheetName).Range(strRangeAddress)) Is Nothing Then
blnRangeContainsShapes = True
Exit For
End If
Next
If blnRangeContainsShapes Then _
strTempText = fncConvertPictureToMail(strTempText, Worksheets(strWorksheetName))
fncRangeToHtml = strTempText
Set objTextstream = Nothing
Set objFilesytem = Nothing
Kill strFilename
End Function
Public Function fncConvertPictureToMail(strTempText As String, objWorksheet As Worksheet) As String
Const HTM_START = "<link rel=File-List href="
Const HTM_END = "/filelist.xml"
Dim strTemp As String
Dim lngPathLeft As Long
lngPathLeft = InStr(1, strTempText, HTM_START)
strTemp = Mid$(strTempText, lngPathLeft, InStr(lngPathLeft, strTempText, ">") - lngPathLeft)
strTemp = Replace(strTemp, HTM_START & Chr$(34), "")
strTemp = Replace(strTemp, HTM_END & Chr$(34), "")
strTemp = strTemp & "/"
strTempText = Replace(strTempText, strTemp, Environ$("temp") & "\" & strTemp)
fncConvertPictureToMail = strTempText
End Function
I'm not a 100% sure but this seems to be cause by your rng to html function.
I had a similar problem with an older range to html I was using, so my solution is a kind of workaround, by rewriting the function you are using.
Can't comment for lack of rep, so please take it with a grain of salt.
I'd suggest using this range_to_html function and expanding it with a workbook open/activate call for your workbook/sheet:
Function RangetoHTML(rng As Range) ' converts a range into html for email-sendout'
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
Dim FSO As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
' Copy the range and create a workbook to receive the data.
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
' Publish the sheet to an .htm file.
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
filename:=TempFile, _
sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
' Read all data from the .htm file into the RangetoHTML subroutine.
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ts = FSO.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
' Close TempWB.
TempWB.Close savechanges:=False
' Delete the htm file.
Kill TempFile
Set ts = Nothing
Set FSO = Nothing
Set TempWB = Nothing
End Function
I've used this for everything range related and no matter what it picked out it was always in line with the general email format.
Source: http://www.mrexcel.com/forum/excel-questions/485720-ron-de-bruin-rangetohtml.html
Since you are reading directly from the file the html might contain the allign command for the code. This one here does copying, and republishing which should circumvent the issue.
I'm also not sure how this code handles shapes, so it might not work for ranges with shapes.
Also if I misunderstood and the problem is that the text in the cells is left aligned lemme know, that would be easier to identify and fix.
I have a situation where i need to place a header line of information into a CSV file.
After which, i will need to append 3 queries, of varying column numbers, to this file.
Currently have this logic, but the TransferText line overwrites what i had placed in the file prior to it:
Dim fldr As String
Dim dlg As Office.FileDialog
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
With dlg
.AllowMultiSelect = False
.Title = "Select a Folder:"
.Filters.Clear
'.Filters.Add "CSV Files", "*.csv"
If .show = True Then
fldr = .SelectedItems(1)
End If
End With
GC dlg
'TODO: Remove after Debugging is complete
RaiseAlert "Folder chosen: " & fldr
'-----------------------------------------
Dim file As String
file = fldr & "\Export_DelaGet_" & Format(Now(), "yyyy_mm_dd") & ".csv"
'TODO: Remove after Debugging is complete
RaiseAlert "File: " & file
'-----------------------------------------
'TODO: OpenFile and output the header line
Open file For Output As #1
Print #1, """SYS"",""Some Data""" & vbCrLf
Close 1
'Output Query/View Results to file
DoCmd.TransferText acExportDelim, "MstPrc_Spec", "vwMasterPrices_Output", file, False
Would it be better for me to just Iterate through the query via RecordSet or am i missing something in TransferText?
Unless someone else can provide me a better way of performing this, here is what i have so far.
Dim fldr As String
Dim dlg As Office.FileDialog
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
With dlg
.AllowMultiSelect = False
.Title = "Select a Folder:"
.Filters.Clear
'.Filters.Add "CSV Files", "*.csv"
If .show = True Then
fldr = .SelectedItems(1)
End If
End With
GC dlg
'TODO: Remove after Debugging is complete
' RaiseAlert "Folder chosen: " & fldr
'-----------------------------------------
Dim file As String
file = fldr & "\Export_" & Format(Now(), "yyyy_mm_dd") & ".csv"
'TODO: Remove after Debugging is complete
' RaiseAlert "File: " & file
'-----------------------------------------
'TODO: OpenFile and output the header line
Open file For Output As #1
Print #1, """SYS"",""Some Data""" & vbCrLf
Close 1
Open file For Append As #2
Dim rst As DAO.Recordset, str As String
'Append MasterPrices
Set rst = CurrentDb.OpenRecordset("vwMasterPrices_Output")
If rst.RecordCount > 0 Then
Do While Not rst.EOF
str = """" & rst(0) & """,""" & rst(1) & """,""" & rst(2) & """,""" & rst(3) & """,""" & rst(4) & """," & Format(rst(5), "##0.00")
Print #2, str
'Move Next
rst.MoveNext
Loop
End If
'Append GroupPrice
Set rst = CurrentDb.OpenRecordset("vwGroupPrice_Output")
If rst.RecordCount > 0 Then
Do While Not rst.EOF
str = """" & rst(0) & """,""" & rst(1) & """,""" & rst(2) & """," & Format(rst(3), "##0.00")
Print #2, str
'Move Next
rst.MoveNext
Loop
End If
'Append GroupLocations
Set rst = CurrentDb.OpenRecordset("vwGroupLocations_Output")
If rst.RecordCount > 0 Then
Do While Not rst.EOF
str = """" & rst(0) & """,""" & rst(1) & """," & rst(2)
Print #2, str
'Move Next
rst.MoveNext
Loop
End If
GC rst
Close 2
Unfortunately the TransferText method performs a File-Output and not a File-Append operation. So anything in the file prior to the TransferText is cleared and replaced with the output of the method.
Yes i had to have text qualifiers around Strings for the CSV.