Optimizing Copy and Paste from one workbook to another in VBA - performance

I have several .xlsm templates in a folder. I'm trying to read through all the excel files in that folder and based on the type of the file, it reads through all the sheets in each file and copy specific cells into another my active workbook (ThisWorkbook).
Following is my code and it is working correctly. However it is super slow. I'm looking for any solution that can speed up the code. I've already tried Application.ScreenUpdating = False but still it is very slow. It takes about 10 min for 20 files to be processed.
DO you guys have any suggestion on how to increase the speed.
Thanks Veru mich in Advance
...
Application.ScreenUpdating = False
FileType = "*.xls*"
OutputRow = 5
Range("$B$6:$M$300").ClearContents
filepath = Range("$B$3") & "\"
ThisWorkbook.ActiveSheet.Range("B" & OutputRow).Activate
OutputRow = OutputRow + 1
Curr_File = Dir(filepath & FileType)
Do Until Curr_File = ""
Set FldrWkbk = Workbooks.Open(filepath & Curr_File, False, True)
ThisWorkbook.ActiveSheet.Range("B" & OutputRow) = Curr_File
OutputRow = OutputRow
For Each sht In FldrWkbk.Sheets
ThisWorkbook.ActiveSheet.Range("C" & OutputRow) = sht.Name
If Workbooks(Curr_File).Worksheets(sht.Name).Range("B7") = "Project Number" Then
For i = 1 To 4
If IsEmpty(Workbooks(Curr_File).Worksheets(sht.Name).Cells(10, 5 + 2 * i)) = False Then
With Workbooks(Curr_File).Worksheets(sht.Name)
MyE = .Cells(10, 5 + 2 * i).Value
MyF = .Cells(11, 5 + 2 * i).Value
End With
With ThisWorkbook.ActiveSheet
.Range("D" & OutputRow).Value = "Unit Weight"
.Range("E" & OutputRow).Value = MyE
.Range("F" & OutputRow).Value = MyF
End With
OutputRow = OutputRow + 1
End If
Next
OutputRow = OutputRow - 1
ElseIf Workbooks(Curr_File).Worksheets(sht.Name).Range("C6") = "PROJECT NUMBER" Then
With Workbooks(Curr_File).Worksheets(sht.Name)
MyE = .Range("$H$9").Value
MyF = .Range("$B$9").Value
End With
With ThisWorkbook.ActiveSheet
.Range("D" & OutputRow).Value = "Specific Gravity"
.Range("E" & OutputRow).Value = MyE
.Range("F" & OutputRow).Value = MyF
End With
ElseIf Workbooks(Curr_File).Worksheets(sht.Name).Range("C6") = "Project Number" Then
With Workbooks(Curr_File).Worksheets(sht.Name)
MyE = .Range("$E$4").Value
MyF = .Range("$R$4").Value
MyG = .Range("$R$5").Value
End With
With ThisWorkbook.ActiveSheet
.Range("D" & OutputRow).Value = "Sieve & Hydrometer"
.Range("E" & OutputRow).Value = MyE
.Range("F" & OutputRow).Value = MyF
.Range("G" & OutputRow).Value = MyG
End With
ElseIf Workbooks(Curr_File).Worksheets(sht.Name).Range("A6") = "PROJECT NUMBER" Then
ThisWorkbook.ActiveSheet.Range("D" & OutputRow).Value = "Moisture Content"
Last = Workbooks(Curr_File).Worksheets(sht.Name).Cells(Rows.Count, "J").End(xlUp).Row
ThisWorkbook.ActiveSheet.Range("I" & OutputRow).Value =
Workbooks(Curr_File).Worksheets(sht.Name).Cells(Last, 10)
ElseIf Workbooks(Curr_File).Worksheets(sht.Name).Range("C5") = "Project Number" Then
With Workbooks(Curr_File).Worksheets(sht.Name)
MyE = .Range("$H$8").Value
MyF = .Range("$B$8").Value
MyG = .Range("$D$8").Value
End With
With ThisWorkbook.ActiveSheet
.Range("D" & OutputRow).Value = "Atterberg Limits"
.Range("E" & OutputRow).Value = MyE
.Range("F" & OutputRow).Value = MyF
.Range("G" & OutputRow).Value = MyG
End With
ElseIf Workbooks(Curr_File).Worksheets(sht.Name).Range("B5") = "Project Number" Then
With Workbooks(Curr_File).Worksheets(sht.Name)
MyE = .Range("$G$4").Value
MyF = .Range("$E$4").Value
MyG = .Range("$E$5").Value
End With
With ThisWorkbook.ActiveSheet
.Range("D" & OutputRow).Value = "Gradation Size"
.Range("E" & OutputRow).Value = MyE
.Range("F" & OutputRow).Value = MyF
.Range("G" & OutputRow).Value = MyG
End With
End If
OutputRow = OutputRow + 1
Next sht
FldrWkbk.Close SaveChanges:=False
Curr_File = Dir
Loop
Set FldrWkbk = Nothing
Application.ScreenUpdating = True
...

I Just realized that the slow performance is due to the formulations that are written in the excel but are linked to the ranges that are pasted from the Macro code. As it was addressed in the previous stack overflow solutions, I simply added "Application.Calculation = xlCalculationManual" in the beginning of the code and "Application.Calculation = xlCalculationAutomatic" at the end of the code and now it is much much faster.
I hope it is also useful to whom is reading this

Related

Error on sending mail using Windows application

In my system, I'm using a windows application project. While I'm sending a mail from the project I get an error as "Creating an instance of the COM component with CLSID {20C62CA0-15DA-101B-B9A8-444553540000} from the IClassFactory failed due to the following error:80040112 Class is not licensed for use (Exception from HRResult: 0x800401120).". Can you please help me with the fix for this? I'm using Windows 10 OS.
Dim oMAPSession As New MSMAPI.MAPISession <br/>
Dim MAPIMessages As New MSMAPI.MAPIMessages
Do While J > 0
With MAPIMessages
oMAPSession.SignOn()
.SessionID = oMAPSession.SessionID
.Compose()
If attachbio Then
.AttachmentIndex = 0
If CustomTable.GetCustomNumber("TEPrintPerUser") = 1 Then
.AttachmentPathName = g_fpReportsPath & "\tempbio.pdf"
Else
.AttachmentPathName = Application.StartupPath & "\tempbio.pdf"
End If
.AttachmentName = "techbio.pdf"
End If
strRecip = Trim(rdtxtFldNumber.Text)
i = 0
Do
.RecipIndex = i
.RecipType = 1
If InStr(1, strRecip, ";") > 0 Then
.RecipDisplayName = Microsoft.VisualBasic.Left(strRecip, InStr(1, strRecip, ";") - 1)
strRecip = Mid(strRecip, InStr(1, strRecip, ";") + 1)
i = i + 1
Else
If (strRecip <> "") Then
.RecipDisplayName = strRecip
End If
Exit Do
End If
Loop
GetDispatchForm = New FrmDispatch
If g_sidCustomization = "Nebrasky" And GetDispatchForm.rdddlText.SelectedIndex = 1 Then
.MsgSubject = Replace(rdtxtfpSubject.Text, Chr(10), " ")
Else
.MsgSubject = "Text Message " & Date.Now
End If
If tmpTextCapacity <= 0 Or (Not IsNumeric(Microsoft.VisualBasic.Left(.RecipDisplayName, InStr(1, .RecipDisplayName, "#") - 1))) Then
.MsgNoteText = strText
J = 0
Else
.MsgNoteText = Microsoft.VisualBasic.Left(strText, tmpTextCapacity)
End If
.Send()
End With
strText = Mid(strText, tmpTextCapacity + 1)
J = J - tmpTextCapacity
Loop

How Export fpspread to Excel vb6?

I try to export to Excel with the fpsread plugin, but there really is no information on how, I have searched the manual but they only show me how to do it with .net
Will someone have an idea?
I managed to do it was very simple, but wanting to import the titles was the heaviest, but here I leave the code in case any work
Private Sub CmdImportar_Click()
Call Export_Excel(cdgExcel, sprFacturas)
Call HacerBusqueda
End Sub
Public Sub Export_Excel(cdgExcel As CommonDialog, Spread As fpSpread)
Dim Header() As String
Dim I As Integer
Dim j As Integer
Dim x As Integer
With cdgExcel
.CancelError = False
.InitDir = "C:/:"
.Filter = "Excel(*.xls)|*.xls"
.ShowSave
If .filename <> "" Then
Spread.Redraw = False
For I = 1 To Spread.ColHeaderRows
ReDim Header(Spread.MaxCols) As String
Spread.Row = SpreadHeader + (I - 1)
For j = 1 To Spread.MaxCols
Spread.Col = j
Header(j) = Spread.Text & ""
Next j
Spread.MaxRows = Spread.MaxRows + 1
Spread.Row = I
Spread.Action = ActionInsertRow
For j = 1 To Spread.MaxCols
Spread.Col = j
Spread.CellType = Spread.CellType
Spread.TypeHAlign = Spread.TypeHAlign
Spread.TypeVAlign = Spread.TypeVAlign
Spread.Text = Header(j) & ""
Next j
Next I
x = Spread.ExportToExcel(.filename, "Sheet1", "")
For I = 1 To Spread.ColHeaderRows
Spread.Row = 1
Spread.Action = ActionDeleteRow
Next I
If x = True Then
MsgBox .filename & vbNewLine & "Se ha Importado el archivo", vbInformation, "Resultado"
Else
MsgBox "No se ha podido exportar el archivo", vbCritical, "Error"
End If
End If
End With
End Sub

Corporate Signature vbs script assistance needed

I am seeking advise / assistance with my script I have put together from tips online and am phased with one last issue that I am having no success with.
All information from row 4 - 8 to be moved up underneath row 3 next to my logo. Now because of the logo row height, it is causing row 4 - 8 to drop below the logo's row. I have been trying to split / merge columns to no success. Please see picture below.
Here is the code i have been mashing at:
On Error goto 0
Const END_OF_STORY = 6
Set objSysInfo = CreateObject("ADSystemInfo")
' ########### This section connects to Active Directory as the currently logged on user
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
sLogoLocation = "\\servername\pic\Sig\logo.jpg"
sStripeLocation = "\\servername\pic\Sig\candystripe.gif"
sLinkAddress = "http://www.yourwebsite.com"
sDisplayLinkText = "www.yourwebsite.com"
sBoldSloganText = "BOLD TEXT USED FOR SLOGAN"
sNormalSloganText = "NORMAL TEXT USED FOR SLOGAN"
' ########### This section sets up the variables we want to call in the script (items on the left; whereas the items on the right are the active directory database field names) - ie strVariablename = objuser.ad.databasename
strGiven = objuser.givenName
strSurname = objuser.sn
strAddress1 = objUser.streetaddress
strAddress1EXT = objUser.postofficebox
strAddress2 = objuser.l
strAddress3 = objuser.st
strPostcode = objuser.postalcode
strCountry = objuser.c
strFax = objuser.facsimileTelephoneNumber
strMobile = objuser.mobile
strTitle = objUser.Title
strDepartment = objUser.Department
strCompany = objUser.Company
strPhone = objUser.telephoneNumber
strEmail = objuser.mail
strWeb = objuser.wWWHomePage
strNotes = objuser.info
strExt = objuser.ipPhone
strDDI = objuser.homephone
strEmailTEXT = "Email: "
strOffice = objuser.physicalDeliveryOfficeName
strPOBOx = objuser.PostOfficeBox
' ########### Sets up word template
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
objSelection.Style = "No Spacing"
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
' ########### Separate main logo from other tables in the script in its own singular column.
' ########### Calls the variables from above section and inserts into word template, also sets initial font typeface, colour etc.
on error resume next
Const wdAlignParagraphRight = 2
Const NUMBER_OF_ROWS = 8
Const NUMBER_OF_COLUMNS = 3
Set objRange = objDoc.Range()
objDoc.Tables.Add objRange, NUMBER_OF_ROWS, NUMBER_OF_COLUMNS
Set objTable = objDoc.Tables(1)
objTable.Cell(1, 1).Width = "3"
objTable.Cell(2, 1).Width = "3"
objTable.Cell(1, 2).Width = "15"
objTable.Cell(2, 2).Width = "15"
objTable.Rows(1).Range.Font.Bold = true
'objTable.Cell(1, 1).Range.Text = ""
objTable.Cell(1, 2).Range.Text = objuser.givenName & " " & objuser.sn & " | " & objuser.Title & " | " & objuser.Department
objTable.Cell(2, 2).Range.InlineShapes.AddPicture(sStripeLocation)
objTable.Cell(3, 1).Width = "3"
objTable.Cell(3, 2).Width = "15"
objTable.Cell(4, 1).Width = "3"
objTable.Cell(4, 2).Width = "10"
objTable.Cell(4, 3).Width = "10"
objTable.Cell(5, 1).Width = "3"
objTable.Cell(5, 2).Width = "15"
objTable.Cell(6, 1).Width = "3"
objTable.Cell(7, 1).Width = "3"
objTable.Cell(8, 1).Width = "3"
objTable.Rows(3).Range.Font.Bold = false
objTable.Rows(4).Range.Font.Bold = false
objTable.Rows(5).Range.Font.Bold = false
objTable.Rows(6).Range.Font.Bold = false
'objTable.Rows(3).Cells(1).Split 1, 5
'objTable.Rows(3).Cells(3).Split 1, 2
objTable.Cell(5, 2).Merge objTable.Cell(5, 8)
objTable.Cell(3, 2).Merge objTable.Cell(3, 6)
objTable.Cell(4, 2).Merge objTable.Cell(4, 6)
objTable.Cell(6, 2).Merge objTable.Cell(6, 6)
objTable.Cell(3, 1).Range.InlineShapes.AddPicture(sLogoLocation)
objTable.Cell(3, 2).Range.Text = "SwitchBoard: " & objuser.TelephoneNumber & " | " & "Extension: " & objuser.physicalDeliveryOfficeName
objTable.Cell(4, 2).Range.Text = "Fax Number: " & objuser.facsimileTelephoneNumber & " | " & "Mobile: " & objuser.Mobile
objTable.Cell(5, 2).Range.Text = "Address: " & objUser.streetaddress & ", " & objuser.l & ", " & objuser.postalcode & ", " & objuser.st & ", " & objuser.c
objTable.Cell(6, 2).Range.Text = "P.O Box: " & objuser.PostOfficeBox
Set objCell = objTable.Cell(7, 2)
Set objCellRange = objCell.Range
objCell.Select
objSelection.TypeText "Website: "
Set objLink = objSelection.Hyperlinks.Add(objSelection.Range, "http://www.mycompany.com", , , "www.mycompany.com")
Set objCell = objTable.Cell(8, 2)
Set objCellRange = objCell.Range
objCell.Select
objSelection.TypeText "E-mail: "
Set objLink = objSelection.Hyperlinks.Add(objSelection.Range, "mailto: " & strEmail, , , strEmail)
objLink.Range.Font.Name = "Verdana"
objLink.Range.Font.Size = 8
objLink.Range.Font.Bold = false
objSelection.Font.Color = RGB (000,045,154)
objSelection.EndKey END_OF_STORY
objSelection.TypeParagraph()
' ####### Used Exchange 2007 for the disclaimer text to ensure all email is covered (this script forces the user to use this as the default signature, it does not however prevent them from selecting another one when writing an email. Would recommend taking a similar approach to cover yourselves.
' ########### Tells outlook to use this signature for new messages and replys. Signature is called Email Signature.
Set objSelection = objDoc.Range()
objSignatureEntries.Add "Email Signature", objSelection
objSignatureObject.NewMessageSignature = "Email Signature"
'objSignatureObject.ReplyMessageSignature = "Email Signature"
objDoc.Saved = True
objWord.Quit

VBS Script for listing out Outlook Profile Info

I have found some code on the Internet for listing out Outlook Profile Info and I would like to it, but it gives the error: Type mismatch:'[string: "A"]', at line 74 (code 800A000D). I don't know why it's not working.
Here is the code:
Option Explicit
Const HKEY_CURRENT_USER = &H80000001
Const r_PSTGuidLocation = "01023d00"
Const r_MasterConfig = "01023d0e"
Const r_PSTCheckFile = "00033009"
Const r_PSTFile = "001f6700"
Const r_keyMaster = "9207f3e0a3b11019908b08002b2a56c2"
Const r_ProfilesRoot = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"
Const r_DefaultProfileString = "DefaultProfile"
Dim oReg:Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
Dim arrSubKeys, subkey, strValue, i, pstFile, arrPSTs, DefaultProfileName
oReg.GetStringValue HKEY_CURRENT_USER,r_ProfilesRoot,r_DefaultProfileString,DefaultProfileName
GetPSTsForProfile(DefaultProfileName)
'_____________________________________________________________________________________________________________________________
Function GetPSTsForProfile(p_profileName)
Dim strHexNumber, strPSTGuid, strFoundPST
oReg.GetBinaryValue HKEY_CURRENT_USER,r_ProfilesRoot & "\" & p_profileName & "\" & r_keyMaster,r_MasterConfig,strValue
If IsUsableArray (strValue) Then
For Each i In strValue
If Len(Hex(i)) = 1 Then
strHexNumber = CInt("0") & Hex(i)
Else
strHexNumber = Hex(i)
End If
strPSTGuid = strPSTGuid + strHexNumber
If Len(strPSTGuid) = 32 Then
If IsAPST(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid) Then
Wscript.Echo PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & _
PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid))
End If
strPSTGuid = ""
End If
Next
End If
End Function
'______________
'_____________________________________________________________________________________________________________________________
Function GetSize(zFile)
Dim objFSO:Set objFSO = CreateObject("Scripting.FileSystemObject")
dim objFile:Set objFile = objFSO.GetFile(zFile)
GetSize = ConvertSize(objFile.Size)
End Function
'_____________________________________________________________________________________________________________________________
Function ConvertSize(Size)
Do While InStr(Size,",") 'Remove commas from size
CommaLocate = InStr(Size,",")
Size = Mid(Size,1,CommaLocate - 1) & _
Mid(Size,CommaLocate + 1,Len(Size) - CommaLocate)
Loop
Dim Suffix:Suffix = " Bytes"
If Size >= 1024 Then suffix = " KB"
If Size >= 1048576 Then suffix = " MB"
If Size >= 1073741824 Then suffix = " GB"
If Size >= 1099511627776 Then suffix = " TB"
Select Case Suffix
Case " KB" Size = Round(Size / 1024, 1)
Case " MB" Size = Round(Size / 1048576, 1)
Case " GB" Size = Round(Size / 1073741824, 1)
Case " TB" Size = Round(Size / 1099511627776, 1)
End Select
ConvertSize = Size & Suffix
End Function
'_____________________________________________________________________________________________________________________________
Function IsAPST(p_PSTGuid)
Dim x, P_PSTGuildValue
Dim P_PSTCheck:P_PSTCheck=0
IsAPST=False
oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTCheckFile,P_PSTGuildValue
If IsUsableArray (P_PSTGuildValue) Then
For Each x in (P_PSTGuildValue)
P_PSTCheck = P_PSTCheck + Hex(x)
Next
End If
If P_PSTCheck=20 Then IsAPST=True
End Function
'_____________________________________________________________________________________________________________________________
Function PSTlocation(p_PSTGuid)
Dim y, P_PSTGuildValue
oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTGuidLocation,P_PSTGuildValue
If IsUsableArray (P_PSTGuildValue) Then
For Each y In P_PSTGuildValue
If Len(Hex(y)) = 1 Then
PSTlocation = PSTlocation & CInt("0") & Hex(y)
Else
PSTlocation = PSTlocation & Hex(y)
End If
Next
End If
End Function
'_____________________________________________________________________________________________________________________________
Function PSTFileName(p_PSTGuid)
Dim z, P_PSTName
Dim strString : strString = ""
oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTFile,P_PSTName
If IsUsableArray (P_PSTName) Then
For Each z in P_PSTName
If z > 0 Then strString = strString & Chr(z)
Next
End If
PSTFileName = strString
End Function
'_________________________________________________________________________________________________________
Function ExpandEvnVariable(ExpandThis)
Dim objWSHShell:Set objWSHShell = CreateObject("WScript.Shell")
ExpandEvnVariable = objWSHShell.ExpandEnvironmentStrings("%" & ExpandThis & "%")
End Function
'_________________________________________________________________________________________________________
Function IsUsableArray(rvnt)'-- Use this function to test for a Null, Empty or an undimensioned array.'-- Useful b/c some interfaces can hold properties for which if they have a'-- value will be an Array but may also be Null or an undimensioned Array.
'-- It assumes that a Null or Empty could potentially be an array but not yet dimensioned. '-- It returns -1 if it is passed a string, long, etc...'-- It returns 0 for an empty array or the number of elements in the first dimension.
IsUsableArray = 0
If (VarType(rvnt) And 8192) = 8192 Then
IsUsableArray = UBound(rvnt) - LBound(rvnt) + 1
Else
If Not (IsEmpty(rvnt) Or IsNull(rvnt)) Then IsUsableArray = -1
End If
End Function
The script works on my system if i correct the extra space at line 8 (Windows Messaging Subsystem)
It is a big script for what it offers, see here for a smaller one which offers more using the free to download library Redemption at http://www.dimastr.com/redemption/home.htm which is what CDO should have been.
set Session = CreateObject("Redemption.RDOSession")
const skUnknown = 0, olStoreANSI = 1, olStoreUnicode = 2, skPrimaryExchangeMailbox = 3, skPublicFolders = 5, skDelegateExchangeMailbox = 4
Session.Logon
for each Store in Session.Stores
if (Store.StoreKind = olStoreANSI) then
wscript.echo Store.Name & " - " & Store.PstPath & " " & Store.Name
elseif (Store.StoreKind = olStoreUnicode) Then
wscript.echo Store.Name & " - " & Store.PstPath
ElseIf (Store.StoreKind = skPrimaryExchangeMailbox) or (Store.StoreKind = skDelegateExchangeMailbox) or (Store.StoreKind = skPublicFolders) Then
wscript.echo Store.Name & " - " & Store.ServerDN
Else
wscript.echo Store.Name & " - " & Store.StoreKind
End If
next

Convert Seconds to Weeks, Days, Hours, Minutes, Seconds in VBScript

Is there a function to convert a specified number of seconds into a week/day/hour/minute/second time format in vbscript?
eg: 969234 seconds = 1wk 4days 5hrs 13mins 54secs
Dim myDate
dim noWeeks
dim noDays
dim tempWeeks
dim pos
myDate = DateAdd("s",969234,CDate(0))
tempWeeks = FormatNumber(myDate / 7,10)
pos = instr(tempWeeks, ".")
if pos > 1 then
tempWeeks = left(myDate, pos -1)
end if
noWeeks = Cint(tempWeeks)
noDays = Cint(((myDate / 7) - noWeeks) * 7)
wscript.echo noWeeks & "wk " & noDays & "days " & datepart("h", myDate) & "hrs " & datepart("n", myDate) & "mins " & datepart("s", myDate) & "secs"
No built in function to do that.
Here is a quick and dirty one:-
Function SecondsToString(totalSeconds)
Dim work : work = totalSeconds
Dim seconds
Dim minutes
Dim hours
Dim days
Dim weeks
seconds = work Mod 60
work = work \ 60
minutes = work Mod 60
work = work \ 60
hours = work Mod 24
work = work \ 24
days = work Mod 7
work = work \ 7
weeks = work
Dim s: s = ""
Dim renderStarted: renderStarted = False
If (weeks <> 0) Then
renderStarted = True
s = s & CStr(weeks)
If (weeks = 1) Then
s = s & "wk "
Else
s = s & "wks "
End If
End If
If (days <> 0 OR renderStarted) Then
renderStarted = True
s = s & CStr(days)
If (days = 1) Then
s = s & "day "
Else
s = s & "days "
End If
End If
If (hours <> 0 OR renderStarted) Then
renderStarted = True
s = s & CStr(hours)
If (hours = 1) Then
s = s & "hr "
Else
s = s & "hrs "
End If
End If
If (minutes <> 0 OR renderStarted) Then
renderStarted = True
s = s & CStr(minutes)
If (minutes = 1) Then
s = s & "min "
Else
s = s & "mins "
End If
End If
s = s & CStr(seconds)
If (seconds = 1) Then
s = s & "sec "
Else
s = s & "secs "
End If
SecondsToString = s
End Function
You wantto use timer pseudo-variable :
start = timer
Rem do something long
duration_in_seconds = timer - start
wscript.echo "Duration " & duration_in_seconds & " seconds."

Resources