I'm trying to write a function that returns the number of bits set in a 32-bit integer in VBScript, it's just for practising the language. The function I've written so far looks okay, but I'm wondering if there was a simpler solution. ``` Function countBits(value) Dim n : n = 0 Dim mask : mask = 1 Dim i For i = 0 to 30 If (value And mask) > 0 Then n = n +1 End If Next If (value And &h8000) then n = n+1 End If countBits = n End Function ``` I found that there are no shift operators in VBScript and an overflow (`Err.Number = 6`) if I iterate for 0 to 31, that's why I add the explicitly check of the MSB after the look. Any solutions to improve (maybe generalize) this? edit: removed the useless error handling part, as it's a remains of starting with 31 as an upper bound in the first (and at that time only) loop

I have 2 Excel files: the first is the source file "Practice_New.xlsx" and the second is a mapping file "A_File.xlsx". A_File is a mapping file which contains cell reference of the source file ("Practice_New.xlsx") to the target file (I need to create this file, say "Practice_New_Output.xlsx"). I have written this code to achieve that but it's taking huge time to complete. Data volume in the source Excel is more than 500 rows sometime. The main issue in my code is that it's opening and closing same file every time in the loop and that is why it's taking huge time. I am not very good in VBA coding. Can anyone please help me to tune up this code to perform better? ``` Sub COPYCELL() Dim wbk As Workbook Dim x% Application.DisplayAlerts = False strParamFile = "C:\Users\rezaul.hasan\Desktop\Practice\A_FILE.xlsx" Workbooks.Open Filename:="C:\ Important\A_FILE.xlsx" Sheets("Sheet1").Select TargetFilename = Range("G2").Value SourceFilename = Range("A2").Value SourceTabName = Range("B2").Value Set wbkt = Workbooks.Add wbkt.SaveAs Filename:=" C:\ Important \" & TargetFilename & ".xlsx", FileFormat:=51 wbkt.Close strFirstFile = " C:\ Important \" & SourceFilename & ".xlsx" 'Take the source excel strSecondFile = " C:\ Important \" & TargetFilename & ".xlsx" 'take the target excel Set wbkM = Workbooks.Open(strParamFile) Set sh1 = Sheets("Sheet1") lr = Range("C" & Rows.Count).End(xlUp).Row For x = 2 To lr Source = sh1.Range("C" & x).Value Target1 = sh1.Range("E" & x).Value Target2 = sh1.Range("F" & x).Value Set wbkS = Workbooks.Open(strFirstFile) With wbkS.Sheets(SourceTabName) .Range(Source).Copy End With Set wbk = Workbooks.Open(strSecondFile) With wbk.Sheets("Sheet1") .Range(Target1, Target2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False End With wbk.Save wbk.Close wbkS.Close Next wbkM.Close End Sub ```

I am working on a project on VBA where the objective is to have a "program" that fetches rates from a website called X-Rates, and outputs to excel the monthly averages of a chosen country. Initially I was doing simple XMLHTTP requests and output to Excel the results. But now I have tried to develop a "pseudo" multithread excel web scraper, based on Daniel Ferry's article on excelhero.com Since I don't know much about VBScript, I think there's enough room for improvement, so I ask please review my code! Apologies for long code! Global Variables: ``` Option Explicit Public Const baseURLpart1 As String = "http://www.x-rates.com/average/?from=" Public Const baseURLpart2 As String = "&to=" Public Const baseURLpart3 As String = "&amount=1&year=" Public Const ARS As String = "ARS" Public Const AUD As String = "AUD" Public Const BRL As String = "BRL" Public Const CNY As String = "CNY" Public Const EUR As String = "EUR" Public Const GBP As String = "GBP" Public Const JPY As String = "JPY" Public Const MXN As String = "MXN" Public Const USD As String = "USD" ``` Format the sheet on workbook: ``` Private Sub FormatResultSheet() 'We will center the cells to give a better readability of results and format as text to keep all zeros . Ex: 1.000000 Dim TargetRange As Range Set TargetRange = ResultSheet.Range("A:F") TargetRange.HorizontalAlignment = xlCenter TargetRange.NumberFormat = "@" End Sub ``` Add headers: ``` Private Sub AddHeader() 'Header cells exist to represent what values are extracted in what columns and are "styled" to stand out for better readability Dim arr(1 To 6) As String arr(1) = "Year" arr(2) = "OffSetCurr" arr(3) = "Month" arr(4) = "toEuro" arr(5) = "toDollars" arr(6) = "toPounds" ResultSheet.Range("A1:F1") = arr() With ResultSheet .Range("A1", "F1").Style = "Input" .Range("A1", "F1").Font.Bold = True End With End Sub ``` Clear & Check for contents in resu

I wish to make a file to click on to do the 'usual' tasks I would do to clean/perform maintenance on my mother's computer when I'm not present. I made a script file and took a few command lines from Google. Am I on the right path? ``` Option Explicit On Error Resume Next Dim WshShell Dim retVal set WshShell=CreateObject("WScript.Shell") WshShell.run "CCleaner.exe /AUTO" WshShell.run "WiseRegCleaner.exe /AUTO" WshShell.run "Cleanmgr /sagerun:1" WshShell.run "Defrag volume c:" wshshell.run "WiseDiskCleaner.exe /AUTO" wshshell.run "mbam.exe /fullscanterminate" WScript.Quit ```

I was tasked with re-writing a login VBScript we use on about 50 machines. The original script was hacked together by someone who clearly had no idea what they were doing (multiple lines that literally did nothing, including creating persistent shares, deleting them, then recreating them 4+ times in a `ForEach` loop) I don't have any scripting experience in vbs, so I'm assuming there's a good amount of stuff here that should be cleaned up. The ultimate goal is to create up to three mapped drives (`P:`, `Q:`, `R:`) that point at registers in the location. Every site should have an identical set up other than the first two `Const`s, for ease of re-use. ``` Option Explicit Const STORE_NUMBER = "29" Const NUM_REGS = 3 Const EVENT_SUCCESS = 0 Const EVENT_FAIL = 1 Class Mapping Public strLocalDrive Public strUNCPath Public strPersistent Public strUsr Public strPas End Class Dim alMappings : Set alMappings = CreateObject("System.Collections.ArrayList") Dim objNetwork : Set objNetwork = WScript.CreateObject("WScript.Network") Dim oShell : Set oShell = CreateObject("WScript.Shell") ' ## Mapping Objects ## ' POS 1 If NUM_REGS >= 1 Then Dim udtPOSOne : Set udtPOSOne = New Mapping With udtPOSOne .strLocalDrive = "P:" .strUNCPath = "\\10.0." & STORE_NUMBER & ".101\dpalm" .strPersistent = "False" .strUsr = "somename" .strPas = "somepass" End With alMappings.add(udtPOSOne) End If ' POS 2 If NUM_REGS >= 2 Then Dim udtPOSTwo : Set udtPOSTwo = New Mapping With udtPOSTwo .strLocalDrive = "Q:" .strUNCPath = "\\10.0." & STORE_NUMBER & ".102\dpalm" .strPersistent = "False" .strUsr = "somename" .strPas = "somepass" End With alMappings.add(udtPOSTwo) End If ' POS 3 If NUM_REGS >= 3 Then Dim udtPOSThree : Set udtPOSThree = New Mapping With udtPOSThree .strLocalDrive = "R:" .strUNCPath = "\\10.0." & STORE_NUMBER

I've put some code together that helps me search an internal ticket system using an HTA application with some TextBoxes and some embedded VBScript that runs PowerShell scripts. The PowerShell scripts are hard coded to a certain directory and I was wondering if there's a better way to accomplish this task/goal. I really do appreciate any assistance! I'm trying to provide this to co-workers who want things as simple as can be! Here's the HTA code, as it can be seen, the VBScript has hard coded references to the various PowerShell scripts. (Huge thanks to this for the basic code I adapted to my specific needs). ``` Search for IR Sub Resize() window.resizeTo 500,450 TextBox1.Focus End Sub Sub ExecutePowerShell() Dim oShell, appCmd, sSvr, sLast, sDesc, sDate 'Collect value from input form sSvr = document.getElementByID("TextBox1").Value sLast = document.getElementByID("TextBox2").Value sDesc = document.getElementByID("TextBox3").Value sDate = document.getElementByID("choose").Value 'Check for empty server name input box. 'If sSvr = "" Then 'MsgBox "Please enter something in the input form" 'Exit Sub 'End If Set oShell = CreateObject("WScript.Shell") appCmd = "powershell.exe C:\Temp\SearchIR.ps1 " & Chr(39) & sSvr & Chr(39) & " " & Chr(39) & sLast & Chr(39) & " " & Chr(39) & sDesc & Chr(39) & " " & Chr(39) & sDate & Chr(39) oShell.Run appCmd, 0, true End Sub Sub Clearer() TextBox1.Value = "" TextBox2.Value = "" TextBox3.Value = "" TextBox4.Value = "" TextBox5.Value = "" TextBox6.Value = "" TextBox7.Value = "" TextBox8.Value = "" choose.Value = "" ChooseStatus.Value = "" TextBox1.Focus End Sub Sub SearchSR() Dim sSr, sRequest, oSRSearch sRequest = document.getElementByID("TextBox4").Value If sRequest = "" Then MsgBox "Please enter something in the input form" Exit Sub End If Set oSRSearch = CreateObject("WScript.Shell") sSr = "powershell.exe C:\Temp\SearchSR.ps1 " & Chr(39) & sRequest & Chr(39) oSRSearch.Run sSr, 0, true End Sub Sub SearchCR()

I have this vbs file to check if a remote server is accessible. Can I simplify or refactor to make it more robust/efficient? ``` const forReading = 1, forWriting = 2, forAppending = 8 public maxWaitTime maxWaitTime = 60 '1800 '30mins public connLogFileName connLogFileName = "connectionLog.txt" public pathToRemoteServer pathToRemoteServer = "c:\" public errMessage public fs set fs = createObject("scripting.fileSystemObject") pathToRemoteServer = "c:\" ':::::::::::::::::::::::::::::: call mainSub() ':::::::::::::::::::::::::::::: sub mainSub() call createLogFile() errMessage = "" dim curDir curDir = fs.GetAbsolutePathName(".") dim logName logName = curDir & "\" & connLogFileName Dim aFile set aFile = fs.openTextFile(logName, forAppending, True) if (checkFolderPath(pathToRemoteServer)) then aFile.WriteLine lineToWrite & " ok" else aFile.WriteLine lineToWrite & " " & errMessage dim downTime downTime = 0 do Until (checkFolderPath(pathToRemoteServer)) or downTime => maxWaitTime WScript.Sleep 500 'half second downTime = downTime + 0.5 loop aFile.WriteLine lineToWrite & " back after seconds: " & downTime end if aFile.close if not aFile is nothing then set aFile = nothing end sub ':::::::::::::::::::::::::::::: sub createLogFile() dim logName logName = fs.GetAbsolutePathName(".") & "\" & connLogFileName If not fs.FileExists(logName) Then fs.createTextFile logName, false End If end sub '::::::::::::::::::::::::::::::::::::::::: function lineToWrite() dim curUser curUser = createObject("WScript.Network").userName lineToWrite = curUser & ": " & Now() '& vbCrLf end function '::::::::::::::::::::::::::::::::::::::::: function checkFolderPath(folder_path) checkFolderPath = false On Error Resume Next dim fn fn = folder_path & "testfile." & myDateFormat(Now()) dim aFile set aFile = fs.createTextFile(fn, True) if err.Number <> 0 Then errMessage =

I am using the code below to capitalize a string properly. I would like to know if there is a better way to code the surname portion, as the way it stands now can become very bloated depending on how many surnames I plan on adding. This is a follow up to: Capitalize string except for conjunction words ``` Dim conjunctions Dim suffixes Dim surnames Set conjunctions = CreateObject("System.Collections.Arraylist") Set suffixes = CreateObject("System.Collections.Arraylist") Set surnames = CreateObject("System.Collections.Arraylist") conjunctions.Add("a") conjunctions.Add("an") conjunctions.Add("and") conjunctions.Add("as") conjunctions.Add("at") ' etc.... suffixes.Add("ii") suffixes.Add("iii") suffixes.Add("iv") suffixes.Add("vi") suffixes.Add("vii") suffixes.Add("viii") suffixes.Add("ix") surnames.Add("mcdonald") for each item in xTextSplit xWord = item if conjunctions.contains(lcase(item)) then xWord = lcase(item) elseif suffixes.contains(lcase(item)) then xWord = ucase(item) elseif surnames.contains(lcase(item)) then xWord = "Mc" & UCase(Mid(item, 3, 1)) & Mid(item, 4) end if xCompleteWord = xCompleteWord & " " & xWord next queryForHeading = xCompleteWord queryForHeading = Mid(queryForHeading, 2) queryForHeading = UCase(Mid(queryForHeading, 1, 1)) & Mid(queryForHeading, 2) ```

I am using the code below to capitalize words in a string. I do not want conjunction words capitalized, but always want the first character in the string to be capitalized no matter what the word is. Is this the most optimized way of accomplishing this? How could this be improved? ``` xText = queryForHeading xTextSplit = split(xText, " ") for each item in xTextSplit xWord = item if lcase(item) = "a" or lcase(item) = "an" or lcase(item) = "and" or lcase(item) = "as" or lcase(item) = "at" or lcase(item) = "but" or lcase(item) = "by" or lcase(item) = "en" or lcase(item) = "for" or lcase(item) = "if" or lcase(item) = "in" or lcase(item) = "is" or lcase(item) = "nor" or lcase(item) = "of" or lcase(item) = "on" or lcase(item) = "or" or lcase(item) = "per" or lcase(item) = "the" or lcase(item) = "this" or lcase(item) = "to" or lcase(item) = "it" or lcase(item) = "vs." then xWord = lcase(item) elseif lcase(item) = "ii" or lcase(item) = "iii" or lcase(item) = "iv" or lcase(item) = "vi" or lcase(item) = "vii" or lcase(item) = "viii" or lcase(item) = "ix" then xWord = ucase(item) end if xCompleteWord = xCompleteWord & " " & xWord next queryForHeading = xCompleteWord queryForHeading = Mid(queryForHeading, 2) queryForHeading = UCase(Mid(queryForHeading, 1, 1)) & Mid(queryForHeading, 2) ```

Follow up to This Question I took some very good advice and changed my code around a little bit and eliminated some `If` statements. I am not retrieving very much information but it looks so skinny now. Is this a good thing? Is there something that I should add to the code? ``` Dim phoneNode Dim phoneNodeList ReturnData = "" Set phoneNodeList = XmlDoc.SelectNodes("/Record/Case/CaseFormsLoad/PartyLoad/Party/PartyPhones/Phone") If phoneNodeList.Length > 0 Then For Each phoneNode In phoneNodeList If phoneNode.GetAttribute("ConfidentialFlag") = "True" Then ReturnData = ReturnData & phoneNode.Getattribute("PhoneNum") & VbCrLf End If Next End If ``` This code is very readable and simple. Is there anything that I can do to make it shorter, and should I make it shorter? it is a Script and not a fully compiled code.