Dim str
set str = Wscript.Arguments
str = InputBox("Enter the path of the files to be renamed as per e-ctd naming pattern")
IF str = "" THEN Cancelled
Set goFS = CreateObject("Scripting.FileSystemObject")
Dim sSDir : sSDir = str
walkDirIter goFS.GetFolder(sSDir)
Sub walkDirIter(oDir)
Dim dicStack : Set dicStack = CreateObject("Scripting.Dictionary")
Dim nCur : nCur = dicStack.Count
Set dicStack(nCur) = oDir
Do Until nCur >= dicStack.Count
Dim oElm
For Each oElm In dicStack(nCur).Files
If InStr(Lcase(oElm.Name), "apple") <> 0 Then
sName = Replace(Lcase(oElm.Name), "apple", "a1...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "ball") <> 0 Then
sName = Replace(Lcase(oElm.Name), "ball", "b2...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "cat") <> 0 Then
sName = Replace(Lcase(oElm.Name), "cat", "c3....")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "dog") <> 0 Then
sName = Replace(Lcase(oElm.Name), "dog", "d4....")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "elephant") <> 0 Then
sName = Replace(Lcase(oElm.Name), "elephant", "e5...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "fan") <> 0 Then
sName = Replace(Lcase(oElm.Name), "fan", "f6...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "guitar") <> 0 Then
sName = Replace(Lcase(oElm.Name), "guitar", "g7...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "hat") <> 0 Then
sName = Replace(Lcase(oElm.Name), "hat", "h8....")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "ink") <> 0 Then
sName = Replace(Lcase(oElm.Name), "ink", "i9...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "jet") <> 0 Then
sName = Replace(Lcase(oElm.Name), "jet", "j10...")
oElm.Name = sName
End If
Next
For Each oElm In dicStack(nCur).SubFolders
Set dicStack(dicStack.Count) = oElm
Next
nCur = nCur + 1
Loop
End Sub
I was using a vbs script for renaming files in folder and all the subfolders within and it worked properly for me (though its not the best way to write vbs scripts. I am trying to get better). Sometimes renaming files takes a lot of time as there are hundreds of files. So after searching I found that its better to implement the vbs script in hta to get a progress bar and better visuals.
This is as close as I got to it:
<html>
<head>
<title id="title">Rename</title>
<HTA:APPLICATION ID="ProgressBar" APPLICATIONNAME="ProgressBar" SCROLL="no" MAXIMIZEBUTTON="no" />
<SCRIPT Language="VBScript">
Public x, y, MyTitle
Sub Window_Onload
window.resizeTo 436, 216
y = 1
x = 1
MyTitle = " _ Rename"
End Sub
Sub Go
Set objFSO = CreateObject("Scripting.FileSystemObject")
objStartFolder = path.value
Set objFolder = objFSO.GetFolder(objStartFolder)
Set colFiles = objFolder.Files
For Each fil in colFiles
y = y + 1
Next
For Each fil in colFiles
Progress()
If InStr(Lcase(fil.Name), "apple") < > 0 Then
sName = Replace(Lcase(fil.Name), "apple", "a1...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "ball") < > 0 Then
sName = Replace(Lcase(fil.Name), "ball", "b2...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "cat") < > 0 Then
sName = Replace(Lcase(fil.Name), "cat", "c3....")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "dog") < > 0 Then
sName = Replace(Lcase(fil.Name), "dog", "d4....")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "elephant") < > 0 Then
sName = Replace(Lcase(fil.Name), "elephant", "e5...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "fan") < > 0 Then
sName = Replace(Lcase(fil.Name), "fan", "f6...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "guitar") < > 0 Then
sName = Replace(Lcase(fil.Name), "guitar", "g7...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "hat") < > 0 Then
sName = Replace(Lcase(fil.Name), "hat", "h8....")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "ink") < > 0 Then
sName = Replace(Lcase(fil.Name), "ink", "i9...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "jet") < > 0 Then
sName = Replace(Lcase(fil.Name), "jet", "j10...")
fil.Name = sName
End If
Next
ShowSubfolders objFSO.GetFolder(path.value)
Sub ShowSubFolders(Folder)
For Each Subfolder in Folder.SubFolders
Set objFolder = objFSO.GetFolder(Subfolder.Path)
Set colFiles = objFolder.Files
For Each fil in colFiles
y = y + 1
Next
For each fil in colFiles
Progress()
If InStr(Lcase(fil.Name), "apple") < > 0 Then
sName = Replace(Lcase(fil.Name), "apple", "a1...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "ball") < > 0 Then
sName = Replace(Lcase(fil.Name), "ball", "b2...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "cat") < > 0 Then
sName = Replace(Lcase(fil.Name), "cat", "c3....")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "dog") < > 0 Then
sName = Replace(Lcase(fil.Name), "dog", "d4....")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "elephant") < > 0 Then
sName = Replace(Lcase(fil.Name), "elephant", "e5...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "fan") < > 0 Then
sName = Replace(Lcase(fil.Name), "fan", "f6...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "guitar") < > 0 Then
sName = Replace(Lcase(fil.Name), "guitar", "g7...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "hat") < > 0 Then
sName = Replace(Lcase(fil.Name), "hat", "h8....")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "ink") < > 0 Then
sName = Replace(Lcase(fil.Name), "ink", "i9...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "jet") < > 0 Then
sName = Replace(Lcase(fil.Name), "jet", "j10...")
fil.Name = sName
End If
Next
ShowSubFolders Subfolder
Next
End Sub
Sub Progress
x = x + 1
document.Title = FormatPercent(x / y, 0) & MyTitle
document.all.ProgBarText.innerText = x & "/" & y
document.all.ProgBarDone.innerText = String(x, "_")
document.all.ProgBarToDo.innerText = String(y - x, "_") & "|"
If x = y Then
document.all.ProgBarToDo.innerText = ""
MsgBox "Done"
window.close
End If
End Sub
</SCRIPT>
</head>
<body bgcolor="#D7D7D7">
Path:
<br>
<input type="text" name="path">
<br>
<br>
<!-- Basic buttons -->
<input id="BtnGo" type="button" value="Go" onclick="Go">
<br>
<span id="ProgBarText"></span>
<br>
<span id="ProgBarDone" style="background-color: #3399FF"></span>
<font color="#FFFFFF">
<span id="ProgBarToDo"style="background-color: #C0C0C0"></span>
</font>
</body>
</html>
The problem here is that this hta gives script error with syntax issue for ShowSubfolders objFSO.GetFolder(path.value) so I tried it by removing the SUBFOLDER part and running the hta like this:
<html>
<head>
<title id="title">Rename</title>
<HTA:APPLICATION ID="ProgressBar" APPLICATIONNAME="ProgressBar" SCROLL="no" MAXIMIZEBUTTON="no" />
<SCRIPT Language="VBScript">
Public x, y, MyTitle
Sub Window_Onload
window.resizeTo 436, 216
y = 0
x = 0
MyTitle = " _ Rename"
End Sub
Sub Go
Set objFSO = CreateObject("Scripting.FileSystemObject")
objStartFolder = path.value
Set objFolder = objFSO.GetFolder(objStartFolder)
Set colFiles = objFolder.Files
For Each fil in colFiles
y = y + 1
Next
For Each fil in colFiles
Progress()
If InStr(Lcase(fil.Name), "apple") <> 0 Then
sName = Replace(Lcase(fil.Name), "apple", "a1...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "ball") <> 0 Then
sName = Replace(Lcase(fil.Name), "ball", "b2...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "cat") <> 0 Then
sName = Replace(Lcase(fil.Name), "cat", "c3....")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "dog") <> 0 Then
sName = Replace(Lcase(fil.Name), "dog", "d4....")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "elephant") <> 0 Then
sName = Replace(Lcase(fil.Name), "elephant", "e5...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "fan") <> 0 Then
sName = Replace(Lcase(fil.Name), "fan", "f6...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "guitar") <> 0 Then
sName = Replace(Lcase(fil.Name), "guitar", "g7...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "hat") <> 0 Then
sName = Replace(Lcase(fil.Name), "hat", "h8....")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "ink") <> 0 Then
sName = Replace(Lcase(fil.Name), "ink", "i9...")
fil.Name = sName
End If
If InStr(Lcase(fil.Name), "jet") <> 0 Then
sName = Replace(Lcase(fil.Name), "jet", "j10...")
fil.Name = sName
End If
Next
End Sub
Sub Progress
x = x + 1
document.Title = FormatPercent(x / y, 0) & MyTitle
document.all.ProgBarText.innerText = x & "/" & y
document.all.ProgBarDone.innerText = String(x, "_")
document.all.ProgBarToDo.innerText = String(y - x, "_") & "|"
If x = y Then
document.all.ProgBarToDo.innerText = ""
MsgBox "Done"
window.close
End If
End Sub
</SCRIPT>
</head>
<body bgcolor="#D7D7D7">
Path:
<br>
<input type="text" name="path">
<br>
<br>
<!-- Basic buttons -->
<input id="BtnGo" type="button" value="Go" onclick="Go">
<br>
<span id="ProgBarText"></span>
<br>
<span id="ProgBarDone" style="background-color: #3399FF"></span>
<font color="#FFFFFF">
<span id="ProgBarToDo"style="background-color: #C0C0C0"></span>
</font>
</body>
</html>
This code successfully renames all the relevant file names in just the parent folder. However I still don't see an increasing progress bar and the file number being processed while the hta runs, until the end. After all the files are renamed, it shows the progress bar at the end like this:
Screenshot
I would like to know:
- How to make the progress-bar to stay visible and update accordingly
while the files are being processed by the script and
- A way to include files from subfolders in the parent folder as well for renaming by the script
New Method:
<html>
<head>
<title id="title">Rename</title>
<HTA:APPLICATION ID="ProgressBar" APPLICATIONNAME="ProgressBar"
SCROLL="no" MAXIMIZEBUTTON="no" />
<SCRIPT Language="VBScript">
Sub Window_Onload
window.resizeTo 250, 180
End Sub
Set goFS = CreateObject("Scripting.FileSystemObject")
Dim sSDir : sSDir = "C:\Users\my\Desktop\sections_2_3"
walkDirIter goFS.GetFolder(sSDir)
Sub walkDirIter(oDir)
Dim dicStack : Set dicStack = CreateObject("Scripting.Dictionary")
Dim nCur : nCur = dicStack.Count
Set dicStack(nCur) = oDir
Do Until nCur >= dicStack.Count
Dim oElm
For Each oElm In dicStack(nCur).Files
If InStr(Lcase(oElm.Name), "apple") <> 0 Then
sName = Replace(Lcase(oElm.Name), "apple", "a1...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "ball") <> 0 Then
sName = Replace(Lcase(oElm.Name), "ball", "b2...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "cat") <> 0 Then
sName = Replace(Lcase(oElm.Name), "cat", "c3....")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "dog") <> 0 Then
sName = Replace(Lcase(oElm.Name), "dog", "d4....")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "elephant") <> 0 Then
sName = Replace(Lcase(oElm.Name), "elephant", "e5...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "fan") <> 0 Then
sName = Replace(Lcase(oElm.Name), "fan", "f6...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "guitar") <> 0 Then
sName = Replace(Lcase(oElm.Name), "guitar", "g7...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "hat") <> 0 Then
sName = Replace(Lcase(oElm.Name), "hat", "h8....")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "ink") <> 0 Then
sName = Replace(Lcase(oElm.Name), "ink", "i9...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "jet") <> 0 Then
sName = Replace(Lcase(oElm.Name), "jet", "j10...")
oElm.Name = sName
End If
Next
For Each oElm In dicStack(nCur).SubFolders
Set dicStack(dicStack.Count) = oElm
Next
nCur = nCur + 1
Loop
End Sub
</SCRIPT>
</head>
<body bgcolor="#D7D7D7">
Path:
<br>
<input type="text" name="Path">
<br>
<br>
<!-- Basic buttons -->
<input id="BtnGo" type="button" value="Go" onclick="walkDirIter(oDir)">
<br>
</font>
</body>
</html>
I have tried this New Method to skip the repetition of same code for folders and subfolders separately. This method is easy and compact.
Working VB script:
Dim str
set str = Wscript.Arguments
str = InputBox("Enter the path of the files to be renamed as per e-ctd naming pattern")
IF str = "" THEN Cancelled
Set goFS = CreateObject("Scripting.FileSystemObject")
Dim sSDir : sSDir = str
walkDirIter goFS.GetFolder(sSDir)
Sub walkDirIter(oDir)
Dim dicStack : Set dicStack = CreateObject("Scripting.Dictionary")
Dim nCur : nCur = dicStack.Count
Set dicStack(nCur) = oDir
Do Until nCur >= dicStack.Count
Dim oElm
For Each oElm In dicStack(nCur).Files
If InStr(Lcase(oElm.Name), "apple") <> 0 Then
sName = Replace(Lcase(oElm.Name), "apple", "a1...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "ball") <> 0 Then
sName = Replace(Lcase(oElm.Name), "ball", "b2...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "cat") <> 0 Then
sName = Replace(Lcase(oElm.Name), "cat", "c3....")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "dog") <> 0 Then
sName = Replace(Lcase(oElm.Name), "dog", "d4....")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "elephant") <> 0 Then
sName = Replace(Lcase(oElm.Name), "elephant", "e5...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "fan") <> 0 Then
sName = Replace(Lcase(oElm.Name), "fan", "f6...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "guitar") <> 0 Then
sName = Replace(Lcase(oElm.Name), "guitar", "g7...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "hat") <> 0 Then
sName = Replace(Lcase(oElm.Name), "hat", "h8....")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "ink") <> 0 Then
sName = Replace(Lcase(oElm.Name), "ink", "i9...")
oElm.Name = sName
End If
If InStr(Lcase(oElm.Name), "jet") <> 0 Then
sName = Replace(Lcase(oElm.Name), "jet", "j10...")
oElm.Name = sName
End If
Next
For Each oElm In dicStack(nCur).SubFolders
Set dicStack(dicStack.Count) = oElm
Next
nCur = nCur + 1
Loop
End Sub
How to Sort String with Numeric values using VB Script?
Below are my strings from each row from a table:
"Test 1 pass dec 2"
"Test 3 fail"
"Test 2 pass jun 4"
"Verified"
"Test 10 pass"
"User Accepted"
I would to like get in below order after sorting(natural order):
"Test 1 pass dec 2"
"Test 2 pass jun 4"
"Test 3 fail"
"Test 10 pass"
"User Accepted"
"Verified"
Ways i have tried so far,
Set oAlist=CreateObject("System.Collections.ArrayList")
oAlist.sort
The ArrayList was sorted in below order based on ASCII which I do not prefer:
"Test 1 pass dec 2"
"Test 10 pass"
"Test 2 pass jun 4"
"Test 3 fail"
"User Accepted"
"Verified"
I have tried this link Sort
and i have no idea how to use AppendFormat in my case.
Note:My given string either completely string or string with numbers(dynamic) so not sure how to use RecordSet or AppendFormat here as I am new to programming.
You can have another example.
Sub Sort
Set rs = CreateObject("ADODB.Recordset")
If LCase(Arg(1)) = "n" then
With rs
.Fields.Append "SortKey", 4
.Fields.Append "Txt", 201, 5000
.Open
Do Until Inp.AtEndOfStream
Lne = Inp.readline
SortKey = Mid(Lne, LCase(Arg(3)), LCase(Arg(4)) - LCase(Arg(3)))
If IsNumeric(Sortkey) = False then
Set RE = new Regexp
re.Pattern = "[^0-9\.,]"
re.global = true
re.ignorecase = true
Sortkey = re.replace(Sortkey, "")
End If
If IsNumeric(Sortkey) = False then
Sortkey = 0
ElseIf Sortkey = "" then
Sortkey = 0
ElseIf IsNull(Sortkey) = true then
Sortkey = 0
End If
.AddNew
.Fields("SortKey").value = CSng(SortKey)
.Fields("Txt").value = Lne
.UpDate
Loop
If LCase(Arg(2)) = "a" then SortColumn = "SortKey ASC"
If LCase(Arg(2)) = "d" then SortColumn = "SortKey DESC"
.Sort = SortColumn
Do While not .EOF
Outp.writeline .Fields("Txt").Value
.MoveNext
Loop
End With
ElseIf LCase(Arg(1)) = "d" then
With rs
.Fields.Append "SortKey", 4
.Fields.Append "Txt", 201, 5000
.Open
Do Until Inp.AtEndOfStream
Lne = Inp.readline
SortKey = Mid(Lne, LCase(Arg(3)), LCase(Arg(4)) - LCase(Arg(3)))
If IsDate(Sortkey) = False then
Set RE = new Regexp
re.Pattern = "[^0-9\\\-:]"
re.global = true
re.ignorecase = true
Sortkey = re.replace(Sortkey, "")
End If
If IsDate(Sortkey) = False then
Sortkey = 0
ElseIf Sortkey = "" then
Sortkey = 0
ElseIf IsNull(Sortkey) = true then
Sortkey = 0
End If
.AddNew
.Fields("SortKey").value = CDate(SortKey)
.Fields("Txt").value = Lne
.UpDate
Loop
If LCase(Arg(2)) = "a" then SortColumn = "SortKey ASC"
If LCase(Arg(2)) = "d" then SortColumn = "SortKey DESC"
.Sort = SortColumn
Do While not .EOF
Outp.writeline .Fields("Txt").Value
.MoveNext
Loop
End With
ElseIf LCase(Arg(1)) = "t" then
With rs
.Fields.Append "SortKey", 201, 260
.Fields.Append "Txt", 201, 5000
.Open
Do Until Inp.AtEndOfStream
Lne = Inp.readline
SortKey = Mid(Lne, LCase(Arg(3)), LCase(Arg(4)) - LCase(Arg(3)))
.AddNew
.Fields("SortKey").value = SortKey
.Fields("Txt").value = Lne
.UpDate
Loop
If LCase(Arg(2)) = "a" then SortColumn = "SortKey ASC"
If LCase(Arg(2)) = "d" then SortColumn = "SortKey DESC"
.Sort = SortColumn
Do While not .EOF
Outp.writeline .Fields("Txt").Value
.MoveNext
Loop
End With
ElseIf LCase(Arg(1)) = "tt" then
With rs
.Fields.Append "SortKey", 201, 260
.Fields.Append "Txt", 201, 5000
.Open
Do Until Inp.AtEndOfStream
Lne = Inp.readline
SortKey = Trim(Mid(Lne, LCase(Arg(3)), LCase(Arg(4)) - LCase(Arg(3))))
.AddNew
.Fields("SortKey").value = SortKey
.Fields("Txt").value = Lne
.UpDate
Loop
If LCase(Arg(2)) = "a" then SortColumn = "SortKey ASC"
If LCase(Arg(2)) = "d" then SortColumn = "SortKey DESC"
.Sort = SortColumn
Do While not .EOF
Outp.writeline .Fields("Txt").Value
.MoveNext
Loop
End With
End If
End Sub
Since you are working with strings, you are going to need to write a custom sort function that can parse the test numbers from the strings.
Alternatively, you could pre-process your list and parse the numbers into a separate field, then sort based on that field.
To apply the techniques from here to the problem (using Split instead of a RegExp):
Option Explicit
Dim aInp : aInp = Array( _
"Test 1 pass dec 2" _
, "Test 3 fail" _
, "Test 2 pass jun 4" _
, "Verified" _
, "Test 10 pass" _
, "User Accepted" _
)
WScript.Echo "----- Input:", vbCrLf & Join(aInp, vbCrLf)
Dim aOtp : aOtp = Array( _
"Test 1 pass dec 2" _
, "Test 2 pass jun 4" _
, "Test 3 fail" _
, "Test 10 pass" _
, "User Accepted" _
, "Verified" _
)
WScript.Echo "----- Expected:", vbCrLf & Join(aOtp, vbCrLf)
Dim oNAL : Set oNAL = CreateObject( "System.Collections.ArrayList" )
Dim oSB : Set oSB = CreateObject( "System.Text.StringBuilder" )
Dim sInp, aParts, aWTF
For Each sInp In aInp
aParts = Split(sInp, " ", 3)
Select Case UBound(aParts)
Case 0 ' add 2 blank elms to "verified"
aWTF = aParts
ReDim Preserve aWTF(2)
Case 1 ' put an empty elm in the middle
' aParts = Array( aParts(0), "", aParts(1))
' ==> VBScript runtime error: This array is fixed or temporarily locked
aWTF = Array( aParts(0), "", aParts(1))
Case 2 ' What the doctor ordered
aWTF = aParts
Case Else
Err.Raise "Shit hits fan"
End Select
oSB.AppendFormat_3 "{0}{1,4}{2}", aWTF(0), aWTF(1), aWTF(2)
sInp = oSB.ToString() & "|" & sInp ' dirty trick: append org data th ease 'reconstruction'
oSB.Length = 0
oNAL.Add sInp
Next
oNAL.Sort
ReDim aOut(oNAL.Count - 1)
Dim i
For i = 0 To UBound(aOut)
aOut(i) = Split(oNAL(i), "|")(1)
Next
WScript.Echo "----- Output:", vbCrLf & Join(aOut, vbCrLf)
output:
cscript 37946075.vbs
----- Input:
Test 1 pass dec 2
Test 3 fail
Test 2 pass jun 4
Verified
Test 10 pass
User Accepted
----- Expected:
Test 1 pass dec 2
Test 2 pass jun 4
Test 3 fail
Test 10 pass
User Accepted
Verified
----- Output:
Test 1 pass dec 2
Test 2 pass jun 4
Test 3 fail
Test 10 pass
User Accepted
Verified
Just for fun: The 'same', but using a RegExp (better scaling technique):
...
Dim r : Set r = New RegExp
r.Pattern = "^(\w+\s*)(\d+\s*)?(.*)$"
Dim sInp, m, aParts(2)
Dim i
For Each sInp In aInp
Set m = r.Execute(sInp)
If 1 = m.Count Then
For i = 0 To 2
aParts(i) = m(0).SubMatches(i)
Next
Else
Err.Raise "Shit hits fan"
End If
oSB.AppendFormat_3 "{0}{1,4}{2}", aParts(0), aParts(1), aParts(2)
sInp = oSB.ToString() & "|" & sInp ' dirty trick: append org data to ease 'reconstruction'
...
The problem is on line fourteen. Else is somehow a syntax error, (800A03EA) I'm very new to VBScript.
Dim StrThing, fso, f
Const ForReading = 1, ForWriting = 2
Set fso = CreateObject("Scripting.FileSystemObject")
If f.FileExists("Desktop\testfile") then
StrThing=InputBox("Type your name in")
Set f = fso.OpenTextFile("Desktop\testfile.txt", ForWriting, True)
f.WriteLine "Hello world!"
f.WriteLine "Hello, " & StrThing
Set f = fso.OpenTextFile("Desktop\testfile.txt", ForReading)
WriteLineToFile = f.ReadAll
StrThing=MsgBox("Hello, " & StrThing)
StrThing=MsgBox("Goodbye, " & StrThing)
End if
Else
x=MsgBox("Hello")
f.createTextFile
StrThing=InputBox("Type your name in")
Set f = fso.OpenTextFile("Desktop\testfile.txt", ForWriting, True)
f.WriteLine "Hello world!"
f.WriteLine "Hello, " & StrThing
Set f = fso.OpenTextFile("Desktop\testfile.txt", ForReading)
WriteLineToFile = f.ReadAll
StrThing=MsgBox("Hello, " & StrThing)
StrThing=MsgBox("Goodbye, " & StrThing)
End if
Two changes required here.
else statement started after closing if
f.FileExists ← No object defined for f.
Modified code:
Dim StrThing, fso, f
Const ForReading = 1, ForWriting = 2
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = CreateObject("Scripting.FileSystemObject")
If f.FileExists("Desktop\testfile.txt") then
StrThing=InputBox("Type your name in")
Set f = fso.OpenTextFile("Desktop\testfile.txt", ForWriting, True)
f.WriteLine "Hello world!"
f.WriteLine "Hello, " & StrThing
Set f = fso.OpenTextFile("Desktop\testfile.txt", ForReading)
WriteLineToFile = f.ReadAll
StrThing=MsgBox("Hello, " & StrThing)
StrThing=MsgBox("Goodbye, " & StrThing)
Else
x=MsgBox("Hello")
f.createTextFile
StrThing=InputBox("Type your name in")
Set f = fso.OpenTextFile("Desktop\testfile.txt", ForWriting, True)
f.WriteLine "Hello world!"
f.WriteLine "Hello, " & StrThing
Set f = fso.OpenTextFile("Desktop\testfile.txt", ForReading)
WriteLineToFile = f.ReadAll
StrThing=MsgBox("Hello, " & StrThing)
StrThing=MsgBox("Goodbye, " & StrThing)
End if
Currently I am working on vb6 application. I want to show data in MSFlexgrid But there is no edit Facility in MSFlexgrid Control.
Is there Any way to Edit MSFlexgrid?
There is a way using hidden Textbox. On the double click on the cell the textbox will be visible and Edit is possible here is code snippet check it
Private Sub Form_Load()
'Setting Col And row
MSFlexGrid1.Cols = 3
MSFlexGrid1.Rows = 10
'First row
MSFlexGrid1.TextMatrix(0, 0) = "ID"
MSFlexGrid1.TextMatrix(0, 1) = "Date"
MSFlexGrid1.TextMatrix(0, 2) = "Voucher Type"
'some data
MSFlexGrid1.TextMatrix(1, 0) = "E0000001"
MSFlexGrid1.TextMatrix(2, 0) = "E0000001"
MSFlexGrid1.TextMatrix(1, 1) = "01/04/10"
MSFlexGrid1.TextMatrix(2, 1) = "01/04/10"
MSFlexGrid1.TextMatrix(1, 2) = "Jrnl"
MSFlexGrid1.TextMatrix(2, 2) = "Jrnl"
End Sub
Private Sub MSFlexGrid1_DblClick()
'If MSFlexGrid1.Col = 3 Or MSFlexGrid1.Col = 6 Or MSFlexGrid1.Col = 7 Then
GridEdit Asc(" ")
'End If
End Sub
Private Sub MSFlexGrid1_KeyPress(KeyAscii As Integer)
GridEdit KeyAscii
End Sub
Sub GridEdit(KeyAscii As Integer)
'use correct font
Text1.FontName = MSFlexGrid1.FontName
Text1.FontSize = MSFlexGrid1.FontSize
Select Case KeyAscii
Case 0 To Asc(" ")
Text1 = MSFlexGrid1
Text1.text = Trim(Text1.text)
Text1.SelStart = 1000
Case Else
Text1 = MSFlexGrid1
Text1.text = Trim(Text1.text)
Text1.SelStart = 1000
End Select
'position the edit box
Text1.Left = MSFlexGrid1.CellLeft + MSFlexGrid1.Left
Text1.Top = MSFlexGrid1.CellTop + MSFlexGrid1.Top
Text1.Width = MSFlexGrid1.CellWidth
Text1.Height = MSFlexGrid1.CellHeight
Text1.Visible = True
Text1.SetFocus
End Sub
Private Sub MSFlexGrid1_LeaveCell()
If Text1.Visible Then
If MSFlexGrid1.Col = 6 Or MSFlexGrid1.Col = 7 Then
If Text1.text = "" Then
Text1.text = " "
End If
End If
MSFlexGrid1 = Text1
Text1.Visible = False
End If
End Sub
Private Sub MSFlexGrid1_GotFocus()
If Text1.Visible Then
If MSFlexGrid1.Col = 6 Or MSFlexGrid1.Col = 7 Then
If Text1.text = "" Then
Text1.text = " "
End If
End If
MSFlexGrid1 = Text1.text
Text1.Visible = False
End If
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
'noise suppression
If MSFlexGrid1.Col <> 6 And MSFlexGrid1.Col <> 7 Then
KeyAscii = 0
End If
If KeyAscii = vbKeyReturn Then
KeyAscii = 0
End If
End Sub
Can you also try below code. This doesnt require text box.
'Put this code in MSFlexGrid Keypress Event
'===================================================
Private Sub MSFlexGrid_KeyPress(KeyAscii As Integer)
With MSFlexGrid
Select Case KeyAscii
Case 8: 'IF KEY IS BACKSPACE THEN
If .Text <> "" Then .Text = _
Left$(.Text, (Len(.Text) - 1))
Case 13: 'IF KEY IS ENTER THEN
Select Case .Col
Case Is < (.Cols - 1):
SendKeys "{right}"
Case (.Cols - 1):
If (.Row + 1) = .Rows Then
.Rows = .Rows + 1
End If
SendKeys "{home}" + "{down}"
End Select
Case Else
.Text = .Text + Chr$(KeyAscii)
'write your own keyascii Validations under
'commented lines
Select Case .Col
Case 0, 1, 2:
'if (your condition(s)) then
'accept only charectors
'Else
' keyascii=0
'End If
Case Else:
End Select
End Select
End With
End Sub
I just started learning VB6 on my own. I have created a simple calculator and I would like it to display the "operator" on the screen.
For example, if I press "1", followed by "plus sign", then finally "8", I would like the calculator to show "1 + 8". And when the "equal" sign is pressed, the calculator should show "1 + 8 = 9".
Below is a very noob code I made:
Dim formula As String
Dim itemOne As Integer
Dim itemTwo As Integer
Private Sub btn1_Click()
txtboxScreen.Text = txtboxScreen.Text & 1
End Sub
Private Sub btn2_Click()
txtboxScreen.Text = txtboxScreen.Text & 2
End Sub
Private Sub btn3_Click()
txtboxScreen.Text = txtboxScreen.Text & 3
End Sub
Private Sub btn4_Click()
txtboxScreen.Text = txtboxScreen.Text & 4
End Sub
Private Sub btn5_Click()
txtboxScreen.Text = txtboxScreen.Text & 5
End Sub
Private Sub btn6_Click()
txtboxScreen.Text = txtboxScreen.Text & 6
End Sub
Private Sub btn7_Click()
txtboxScreen.Text = txtboxScreen.Text & 7
End Sub
Private Sub btn8_Click()
txtboxScreen.Text = txtboxScreen.Text & 8
End Sub
Private Sub btn9_Click()
txtboxScreen.Text = txtboxScreen.Text & 9
End Sub
Private Sub btnDivide_Click()
itemOne = txtboxScreen.Text
txtboxScreen.Text = ""
formula = "/"
End Sub
Private Sub btnEqual_Click()
itemTwo = txtboxScreen.Text
If formula = "+" Then
txtboxScreen.Text = itemOne + itemTwo
ElseIf formula = "-" Then
txtboxScreen.Text = itemOne - itemTwo
ElseIf formula = "*" Then
txtboxScreen.Text = itemOne * itemTwo
ElseIf formula = "/" Then
txtboxScreen.Text = itemOne / itemTwo
End If
End Sub
Private Sub btnMinus_Click()
itemOne = txtboxScreen.Text
txtboxScreen.Text = ""
formula = "-"
End Sub
Private Sub btnPlus_Click()
itemOne = txtboxScreen.Text
txtboxScreen.Text = ""
formula = "+"
End Sub
Private Sub btnTimes_Click()
itemOne = txtboxScreen.Text
txtboxScreen.Text = ""
formula = "*"
End Sub
Private Sub btnZero_Click()
txtboxScreen.Text = txtboxScreen.Text & 0
End Sub
You may want to think about using a control array for you number buttons. This will vastly simplify your code in this instance and especially for more complex projects:
Private formula As String
Private itemOne As Integer
Private itemTwo As Integer
Private Sub btnNumbers_Click(Index As Integer)
txtboxScreen.Text = txtboxScreen.Text & Index
End Sub
''Remainder of your code goes here
Also, when you are declaring variables in the Declaration section of the form you should use Private instead of Dim.
I think you would like to concatenate the operator sign of the pressed button with the value you had in the textbox on button_click event.
something like:
Private Sub btnPlus_Click()
txtboxScreen.Text = txtboxScreen.Text & " + "
End Sub
and on equal button, you'd like to evaluate the expression
Private Sub btnEqual_Click()
txtboxScreen.Text = txtboxScreen.Text & " = " & Eval(txtboxScreen.Text)
End Sub
evaluating using Eval() is not a robust solution, but it's a simple way to achive that functionality.
You should save your first number, second number and operator (you called it "formula") separately and handle setting the text of the text box separately. Here is one way to do it:
Dim formula As String
Dim itemOne As String 'This time this is string
Dim itemTwo As String 'This time this is string
Dim currentItem As String 'Will hold the current number being entered
Dim Result As String 'This is string, too.
All your buttons will have code like:
Private Sub btn1_Click()
currentItem = currentItem & "1"
UpdateText()
End Sub
The operator buttons:
Private Sub btnPlus_Click()
itemOne = currentItem
formula = "+"
UpdateText()
End Sub
And the Equals button:
Private Sub btnEqual_Click()
itemTwo = currentItem
If formula = "+" Then
'Str is optional, but Val's are necessary since
'itemOne and itemTwo are strings.
Result = Str( Val(itemOne) + Val(itemTwo) )
ElseIf ...
.
.
.
End If
UpdateText()
End Sub
Well, noticed the call to UpdateText() at the end of every subprocedure? Here it is:
Private Sub UpdateText()
txtboxScreen.Text = itemOne & formula & itemTwo
'If result is not empty, we will add the '=' part too
If Result <> "" Then
txtboxScreen.Text = txtboxScreen.Text & "=" & Result
End If
End Sub
You might also be interested in an AC/ON key which sets all the variables to "".
The method was not so neat, but it's the best thing you can do without an expression evaluator. An expression evaluator can calculate the entire formula as it is. Eval is such a function and you can find some implementations of it on the net.