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."
Related
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
I'm trying to get the date from an attribute called 'accountExpires' of a computer object in Active Directory. If the object haven't been set it just says 'never' and if you look it just have a many numbers. I made this and it working for the attribute 'lastlogon', but not for 'accountExpires'. Maybe someone can help me out.
I'm using VBscript because our company is using this in our loginscript.
On Error Resume Next
Dim ADSysInfo, objComputer, lobjDate, laccountExpiresDate, WSHShell
Set WSHShell = CreateObject("WScript.Shell")
Set ADSysInfo = CreateObject("ADSystemInfo")
Set objComputer = GetObject("LDAP://" & ADSysInfo.ComputerName)
msgbox objComputer
Set lobjDate = objComputer.get("lastLogon") ' <----- Working ----->
' Set lobjDate = objComputer.get("accountExpires") ' <----- Not Working ----->
msgbox err.number
if IsNull(lobjDate) then
msgbox "No Date"
else
laccountExpiresDate = Integer8Date(lobjDate, getLocaltimeZoneBias)
msgbox laccountExpiresDate
end if
Function Integer8Date(objDate, lngBias)
' Function to convert Integer8 (64-bit) value to a date, adjusted for
' local time zone bias.
Dim lngAdjust, lngDate, lngHigh, lngLow
lngAdjust = lngBias
lngHigh = objDate.HighPart
lngLow = objdate.LowPart
' Account for bug in IADslargeInteger property methods.
If lngLow < 0 Then
lngHigh = lngHigh + 1
End If
If (lngHigh = 0) And (lngLow = 0) Then
lngAdjust = 0
End If
lngDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) + lngLow) / 600000000 - lngAdjust) / 1440
Integer8Date = CDate(lngDate)
End Function
' Obtain local time zone bias from machine registry.
Function getLocaltimeZoneBias
Dim lngBiasKey, lngBias
lngBiasKey = WSHShell.RegRead("HKLM\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias")
If UCase(TypeName(lngBiasKey)) = "LONG" Then
lngBias = lngBiasKey
ElseIf UCase(TypeName(lngBiasKey)) = "VARIANT()" Then
lngBias = 0
For k = 0 To UBound(lngBiasKey)
lngBias = lngBias + (lngBiasKey(k) * 256^k)
Next
End If
getLocaltimeZoneBias = lngBias
End Function 'getLocaltimeZoneBias
I want to create a webcam application that can save image to database. My code is from the internet. My code can only save binary but I guess my conversion was incorrect because I can't retrieve them from the database.
Here is my Code:
Private Sub cmdsave_Click()
OpenDB
rs.Open "tblimg", db, adOpenKeyset, adLockPessimistic, adCmdTable
Dim bytData() As Byte, PicInfo As BITMAP
If Dir(App.path & "\myPic", vbDirectory) = "" Then MkDir (App.path & "\myPic")
File1.path = App.path & "\myPic"
'File1.Pattern = "*.bmp"
File1.Pattern = "*.jpg"
File1.Refresh
Dim Maxnum As Integer, ii As Integer
For ii = 0 To File1.ListCount - 1
If Left(File1.List(ii), 1) = "p" Then
If CInt(Mid(File1.List(ii), 2, Len(File1.List(ii)) - 4)) > Maxnum Then
Maxnum = CInt(Mid(File1.List(ii), 2, Len(File1.List(ii)) - 4))
End If
End If
Next
Picture1.Picture = Image1.Picture
'SavePicture Image1.Picture, App.Path & "\myPic\p" & Maxnum + 1 & ".bmp"
SAVEJPEG App.path & "\myPic\p" & Maxnum + 1 & ".jpg", 100, Me.Picture1
ReDim bytData((PicInfo.bmHeight * PicInfo.bmWidth)) As Byte
With rs
.AddNew
.Fields("Picture").AppendChunk bytData
.Fields("Desc") = Label2.Caption
.Update
End With
Set rs = Nothing
db.Close: Set db = Nothing
End Sub
Hope this code give you idea of what you want to achive
Picture3.Visible = True
SavePicture Picture1.Picture, App.Path & "\Emp Photo\" & UCase(Trim(G_EmpCode)) _ & ".jpg"
Picture3.Picture = LoadPicture(App.Path & "\Emp Photo\" & UCase(Trim(G_EmpCode)) & ".jpg")
Picture2.Picture = LoadPicture(App.Path & "\Emp Photo\" & UCase(Trim(G_EmpCode)) & ".jpg")
FrmEmployee.Image1.Picture = Picture2.Picture
CCTVImagePath = App.Path & "\Emp Photo\" & UCase(Trim(G_EmpCode)) & ".jpg"
Call cmdClose_Click
Call CmdStart_Click
If CCTVImagePath <> "" Then
ImagePath = CCTVImagePath
m_imgfile = CCTVImagePath
End If
If FileSystemObj.FileExists(ImagePath) = True Then
Set strStream = New ADODB.Stream
strStream.Type = adTypeBinary
strStream.Open
Sourcefile = ImagePath
strStream.LoadFromFile Sourcefile
CCTVImagePath = ""
End If
CCTVImagePath = ""
i have huge problem with my event procedure, it takes ages to run when i want to change more than few cells at once. How it works, well when user changes data in cell the Worksheet_Change adds comments, but first the Worksheet_SelectionChange updates informations for user (i have sumifs in different worksheet where it calculates ACT date for 12 months, and then it display via camer tool on active worksheet).
In know that problem is cuz of constant looping through events.... duno what to do ?!
Thx for help!
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
ActiveSheet.Unprotect Password:="xyz"
For Each cell In Target
If cell.Row > 21 And cell.Column > 9 Then
If cell.Comment Is Nothing Then
cell.AddComment Now & " - " & cell.Value & " - " & Application.UserName
Else
If Val(Len(cell.Comment.Text)) > 255 Then
cell.Comment.Delete
cell.AddComment
cell.Comment.Text _
Now & " - " & cell.Value & " - " & Application.UserName, 1 _
, False
Else
cell.Comment.Text _
vbNewLine & Now & " - " & cell.Value & " - " & Application.UserName, Len(cell.Comment.Text) + 1 _
, False
End If
End If
cell.Comment.Shape.TextFrame.AutoSize = True
End If
Next cell
ActiveSheet.Protect Password:="11opkLnm890", AllowFiltering:=True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim RowNumber As Long, i As Long
Dim MaxRowNumber As Long
MaxRowNumber = Range("A9").Value
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
RowNumber = Target.Row
Set sh_AUXILIARY_PT = ThisWorkbook.Worksheets("AUXILIARY_PT")
If Target.Row > 21 And Target.Row < MaxRowNumber Then
sh_AUXILIARY_PT.Range("AA4").Value = Cells(RowNumber, 1).Value
sh_AUXILIARY_PT.Range("AB4").Value = Cells(RowNumber, 2).Value
sh_AUXILIARY_PT.Range("AC4").Value = Cells(RowNumber, 3).Value
sh_AUXILIARY_PT.Range("AD4").Value = Cells(RowNumber, 4).Value
For i = 14 To 25
sh_AUXILIARY_PT.Cells(8, i).Value = Cells(RowNumber, i - 4).Value
Next i
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
well, you may consider assigning your collection range to an Array and then loop through since Arrays are much faster.
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