I want to get the final driving time to be calculated once my employee enters the time returning to office [AActReturn0] to appear in field [AActDrive50] but if AActFinish5 is null I need it to go to AActFinsh4, but if that is null I need it to check AActFinish3, all the way to AActFinish1. I am not sure what I am doing wrong here. I've also tried Dim. I'm at a loss how to do this.
Attempt #1:
Private Sub AActReturn0_AfterUpdate()
If AActFinish5 <> Null Then
AActDrive50 = DateDiff("n", [AActFinish5], [AActReturn0])
ElseIf [AActFinish5] = Null Then
AActDrive50 = DateDiff("n", [AActFinish4], [AActReturn0])
ElseIf [AActFinish4] = Null Then
AActDrive50 = DateDiff("n", [AActFinish3], [AActReturn0])
ElseIf [AActFinish3] = Null Then
AActDrive50 = DateDiff("n", [AActFinish2], [AActReturn0])
ElseIf [AActFinish2] = Null Then
AActDrive50 = DateDiff("n", [AActFinish1], [AActReturn0])
End If
End Sub
Attempt #2:
Private Sub AActReturn0_AfterUpdate()
Dim Final As String
If AActFinish5 <> Null Then Final = AActFinish5
If Final = Null Then Final = AActFinish4
If Final = Null Then Final = AActFinish3
If Final = Null Then Final = AActFinish2
If Final = Null Then Final = AActFinish1
AActDrive50 = DateDiff("n", [Final], [AActReturn0])
End Sub
You can use Nz:
Private Sub AActReturn0_AfterUpdate()
Dim Final As Date
Final = Nz(AActFinish5, Nz(AActFinish4, Nz(AActFinish3, Nz(AActFinish2, Nz(AActFinish1)))))
AActDrive50 = DateDiff("n", [Final], [AActReturn0])
End Sub
Related
I can't find where I'm going wrong to make the structuring for the levels.
As the attached image is made with a file below it opens until the end. (file basically has single cascade)
The image on the right, on the other hand, contains a level above that has files contained in 3 different levels..
I believe I'm going around a lot to be able to structure according to the files.
structure
Public Class Form1
Public list As New List(Of Linha)
Public Lid As Integer = 0
Dim iPathDoc As String
Private MainSub()
Dim strDocName As String
strDocName = oApprenticeApp.FileManager.GetFullDocumentName(txtFileName.Text, 'Master')
oApprenticeServerDoc = oApprenticeApp.Open(strDocName)
iPathDoc = Microsoft.VisualBasic.Left(oApprenticeServerDoc.FullFileName, InStrRev(oApprenticeServerDoc.FullFileName, '\'))
BuildTreeView()
'Build child nodes
SubNivel()
End Sub
Sub SubNivel()
Dim Final As Boolean = False
'run while finish all list,
'bug ( some times where add a new item at list, its not include on final.. so list is not in sort(how create)
If list.Count <> 0 Then
Do While Final = False
For n = 0 To list.Count - 1
'search each line from list if there reg=false
If list(n).reg = False Then
'if false put = False
Final = False
'if false open
BuildTreeViewRef(list(n).pai, list(n).filho)
Else
'case the item = True
Final = True
End If
Next
Loop
End If
End Sub
Private Sub BuildTreeView()
'set main node
Dim conj As TreeNode = TreeView1.Nodes.Add(oApprenticeServerDoc.FullFileName, oApprenticeServerDoc.DisplayName)
Dim oRefFileDesc As ReferencedFileDescriptor
For Each oRefFileDesc In oApprenticeServerDoc.ReferencedFileDescriptors
If oRefFileDesc.DocumentType = Inventor.DocumentTypeEnum.kAssemblyDocumentObject Then
conj.Nodes.Add(oRefFileDesc.FullFileName, oRefFileDesc.DisplayName, 0, 0)
'add on list each new assy
'creates in order to list = Lid
Lid = Lid + 1
list.Add(New Linha(Lid, oApprenticeServerDoc.FullFileName, oRefFileDesc.FullFileName, False))
Else
conj.Nodes.Add(oRefFileDesc.FullFileName, oRefFileDesc.DisplayName, 1, 1)
End If
Next
End Sub
Private Sub BuildTreeViewRef(Painode As String, refDocName As String)
'open refdoc and local
Dim oRefDoc As String
oRefDoc = oApprenticeApp.FileManager.GetFullDocumentName(refDocName, 'Master')
Dim oAssyDoc As Inventor.ApprenticeServerDocument
oAssyDoc = oApprenticeApp.Open(refDocName)
'set node where include the refDocname, = painode
Dim Root() As TreeNode
Root = TreeView1.Nodes.Find(Painode, True) 'TreeView1.SelectedNode
Dim SubCj() As TreeNode
'check all roots from pai
'If Root.Length > 1 Then
For i = 0 To Root.Length - 1
SubCj = Root(i).Nodes.Find(refDocName, True) 'TreeView1.SelectedNode
Dim oRefFileDesc As ReferencedFileDescriptor
For Each oRefFileDesc In oAssyDoc.ReferencedFileDescriptors
If oRefFileDesc.DocumentType = Inventor.DocumentTypeEnum.kAssemblyDocumentObject Then
SubCj(0).Nodes.Add(oRefFileDesc.FullFileName, oRefFileDesc.DisplayName, 0, 0)
Lid = Lid + 1
list.Add(New Linha(Lid, refDocName, oRefFileDesc.FullFileName, False))
Else
SubCj(0).Nodes.Add(oRefFileDesc.FullFileName, oRefFileDesc.DisplayName, 1, 1)
End If
Next
Next
'check if really the item goes to treeview
For n = 0 To list.Count - 1
If list(n).pai = Painode And list(n).filho = refDocName Then
list(n).reg = True
End If
Next
End Sub
Public Class Linha
Public Property Id() As Integer
Public Property pai() As String
Public Property filho() As String
Public Property reg As Boolean
Public Sub New(ByVal _id As Integer, ByVal _pai As String, ByVal _filho As String, ByVal _reg As Boolean)
Me.Id = _id
Me.pai = _pai
Me.filho = _filho
Me.reg = _reg
End Sub
End Class
The below code will split 1 cell into 3 or 4 column based on a pattern of 6chr,5chr,4chr,5+chr. The below also needs to be available on all open workbooks and work from the user selection.
How to fix a bug that after the first splitting of the cell is done and by mistake you run it again will override the data?
Class Module
Option Explicit
'Rename this Class Module cFabric
Private pStyle As String
Private pFabric As String
Private pColour As String
Private pSize As String
Public Property Get Style() As String
Style = pStyle
End Property
Public Property Let Style(Value As String)
pStyle = Value
End Property
Public Property Get Fabric() As String
Fabric = pFabric
End Property
Public Property Let Fabric(Value As String)
pFabric = UCase(Value)
End Property
Public Property Get Colour() As String
Colour = pColour
End Property
Public Property Let Colour(Value As String)
pColour = Value
End Property
Public Property Get Size() As String
Size = pSize
End Property
Public Property Let Size(Value As String)
pSize = Value
End Property
Regular Module
Option Explicit
Sub Fabrics()
Dim wsSrc As Workbook, wsRes As Workbook
Dim vSrc As Variant, vRes As Variant, rRes As Range
Dim RE As Object, MC As Object
Const sPat As String = "^(.{6})\s*(.{5})\s*(.{4})(?:.*1/(\S+))?"
'Group 1 = style
'Group 2 = fabric
'Group 3 = colour
'Group 4 = size
Dim colF As Collection, cF As cFabric
Dim I As Long
Dim S As String
Dim V As Variant
'Set source and results worksheets and ranges
Set wsSrc = ActiveWorkbook
Set wsRes = ActiveWorkbook
Set rRes = wsRes.Application.Selection
'Read source data into array
vSrc = Application.Selection
'Initialize the Collection object
Set colF = New Collection
'Initialize the Regex Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False
.MultiLine = True
.Pattern = sPat
'Test for single cell
If Not IsArray(vSrc) Then
V = vSrc
ReDim vSrc(1 To 1, 1 To 1)
vSrc(1, 1) = V
End If
'iterate through the list
For I = 1 To UBound(vSrc, 1)
S = vSrc(I, 1)
Set cF = New cFabric
If .test(S) = True Then
Set MC = .Execute(S)
With MC(0)
cF.Style = .submatches(0)
cF.Fabric = .submatches(1)
cF.Colour = .submatches(2)
cF.Size = .submatches(3)
End With
Else
cF.Style = S
End If
colF.Add cF
Next I
End With
'create results array
'Exit if no results
If colF.Count = 0 Then Exit Sub
ReDim vRes(1 To colF.Count, 1 To 4)
'Populate the rest
I = 0
For Each V In colF
I = I + 1
With V
vRes(I, 1) = .Style
vRes(I, 2) = .Fabric
vRes(I, 3) = .Colour
vRes(I, 4) = .Size
End With
Next V
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
rRes.Value = vRes
End Sub
Credits for the above goes to #Ron Rosenfeld for the project!
One way to tell if the entry has been previously split is as follows
If the regex.test fails, then
If the results line passes, then the item has been previously split
if not, then it is a blank, or a malformed entry
Note that a lot of this could be avoided if you were not overwriting your original data. I would recommend against overwriting your data both for audit and debugging purposes, but the below should help in case you cannot change that.
You just need to make some small changes in the logic where we checked for the malformed entry originally. As well as reading in the "possible" results array into vSrc so that we have the potentially split data to compare:
Option Explicit
Sub Fabrics()
'assume data is in column A
Dim wsSrc As Worksheet, wsRes As Worksheet
Dim vSrc As Variant, vRes As Variant, rRes As Range
Dim RE As Object, MC As Object
Const sPat As String = "^(.{6})\s*(.{5})\s*(.{4})(?:.*1/(\S+))?"
'Group 1 = style
'Group 2 = fabric
'Group 3 = colour
'Group 4 = size
Dim colF As Collection, cF As cFabric
Dim I As Long
Dim S As String
Dim V As Variant
'Set source and results worksheets and ranges
Set wsSrc = ActiveSheet
Set wsRes = ActiveSheet
Set rRes = Selection
'Read source data into array
vSrc = Selection.Resize(columnsize:=4)
'Initialize the Collection object
Set colF = New Collection
'Initialize the Regex Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False
.MultiLine = True
.Pattern = sPat
'iterate through the list
'Test for single cell
If Not IsArray(vSrc) Then
V = vSrc
ReDim vSrc(1 To 1, 1 To 1)
vSrc(1, 1) = V
End If
For I = 1 To UBound(vSrc, 1)
S = vSrc(I, 1)
Set cF = New cFabric
If .test(S) = True Then
Set MC = .Execute(S)
With MC(0)
cF.Style = .submatches(0)
cF.Fabric = .submatches(1)
cF.Colour = .submatches(2)
cF.Size = .submatches(3)
End With
ElseIf .test(vSrc(I, 1) & vSrc(I, 2) & vSrc(I, 3)) = False Then
cF.Style = S
Else
cF.Style = vSrc(I, 1)
cF.Fabric = vSrc(I, 2)
cF.Colour = vSrc(I, 3)
cF.Size = vSrc(I, 4)
End If
colF.Add cF
Next I
End With
'create results array
'Exit if not results
If colF.Count = 0 Then Exit Sub
ReDim vRes(1 To colF.Count, 1 To 4)
'Populate
I = 0
For Each V In colF
I = I + 1
With V
vRes(I, 1) = .Style
vRes(I, 2) = .Fabric
vRes(I, 3) = .Colour
vRes(I, 4) = .Size
End With
Next V
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.Clear
.NumberFormat = "#"
.Value = vRes
.EntireColumn.AutoFit
End With
End Sub
Disregarding the previous regex/class method,
Option Explicit
Sub Fabrics_part_Deux()
Dim a As Long, b As Long
With Worksheets("Sheet1")
If .AutoFilterMode Then .AutoFilterMode = False
With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp).Offset(0, 3))
With .Columns("B")
.Offset(1, 0).Replace what:=Chr(32), replacement:=vbNullString, lookat:=xlPart
End With
.AutoFilter field:=2, Criteria1:="<>"
.AutoFilter field:=3, Criteria1:=""
With .Resize(.Rows.Count - 1, 1).Offset(1, 1)
If CBool(Application.Subtotal(103, .Cells)) Then
With .SpecialCells(xlCellTypeVisible)
For a = 1 To .Areas.Count
With .Areas(a).Cells
.TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(6, 1), Array(11, 1), Array(15, 2))
For b = 1 To .Rows.Count
.Cells(b, 2) = UCase$(.Cells(b, 2).Value2)
If CBool(InStr(1, .Cells(b, 4).Value2, Chr(47), vbBinaryCompare)) Then
.Cells(b, 4) = Trim(Split(.Cells(b, 4), Chr(47))(1))
End If
Next b
End With
Next a
End With
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
In your code to output to the spreadsheet, you need to check for empty strings
I = 0
For Each V In colF
I = I + 1
With V
vRes(I, 1) = .Style
If len(.Fabric) > 0 then
vRes(I, 2) = .Fabric
vRes(I, 3) = .Colour
vRes(I, 4) = .Size
End If
End With
Next V
I've been trying to implement some custom grouping with Infragistics xamDataGrid (Infragistics3.Wpf.DataPresenter.v9.1.Express), and pretty much cribbed the entire bit of code from the Infragistics site. I have two different date fields -- Due Date, and Reminder Date -- using GroupByEvaluator. Everything seemed well and good until I tried to add both fields to the GroupByArea.
What happens is this: the nested field groups according to the date of the parent field as opposed to grouping of the parent field. For example, when I drag the "Due Date" (parent) field to the GroupBy, it'll group these records by Due Date into four categories -- Due Next Year, Due This Year, Past Due, and Not Set. Perfect. But when I drag the "Reminder Date" field (nested) to the GroupBy, I'll find multiple labels of the same "Reminder Date" grouping nested under Due Date "Past Due".
I'm a newbie posting to SO, so I can't post an image. Instead, I'll type one out:
Past Due (Due Date)
Not Set (Reminder Date)
This Month (Reminder Date)
Not Set (Reminder Date)
Older (Reminder Date)
Not Set (Reminder Date)
etc....
With each subsequent nested grouping, the earliest Due Date (value of the parent grouping) is equal to or greater than the greatest Due Date of the previous grouping. It appears as though the "Past Due" collection is sorted by Due Date asc, and it's iterating through each record and creating a new nested group whenever there is a change in the nested label. So after 5 groupByRecords are given the label of "This Month", when the next "Not Set" groupByRecord pops up a new nested label is created instead of continuing to populate the existing one.
I'm having a related issue with sorting, which I suspect is what this entire issue hinges on. If the grid has been sorted according to Due Date, all of the sort by functionality of the other fields are constrained by the Due Dates. For example, sorting by client name will not sort all client name records into ascending or descending. Instead, it will sort, but it sort by Due Date first, and then Name.
Sorry I can't attach an image. Hopefully I explained the issue okay.
Thanks in advance! Code below:
Imports System.Collections.ObjectModel
Imports Infragistics.Windows.DataPresenter
Imports System.Windows
Imports System.Windows.Controls
Partial Public Class ManageEntities
Public Sub New()
' This call is required by the designer.
InitializeComponent()
' Add any initialization after the InitializeComponent() call.
Me.InitializeGroupByGrid()
End Sub
#Region "CustomGrouping"
'http://help.infragistics.com/Help/Doc/WPF/2012.2/CLR4.0/html/InfragisticsWPF4.DataPresenter.v12.2~Infragistics.Windows.DataPresenter.IGroupByEvaluator.html
Private Sub InitializeGroupByGrid()
For Each f In Me.SelectorGrid.FieldLayouts(0).Fields
If f.Name = "Form1DueDate" OrElse f.Name = "Form1LastReminderDate" Then
f.Settings.GroupByEvaluator = New CustomDateTimeEvaluator
' group by the data field
Dim fsd As FieldSortDescription = New FieldSortDescription()
fsd.Field = f
fsd.Direction = System.ComponentModel.ListSortDirection.Descending
Me.SelectorGrid.FieldLayouts(0).SortedFields.Add(fsd)
End If
Next
End Sub
#End Region
End Class
#Region "CustomDateTimeEvaluator"
'//20150918 - From infragistics: http://help.infragistics.com/Help/Doc/WPF/2013.1/CLR4.0/html/InfragisticsWPF4.DataPresenter.v13.1~Infragistics.Windows.DataPresenter.IGroupByEvaluator.html
Friend Class CustomDateTimeEvaluator
Implements IGroupByEvaluator
Private Const NotSet As String = "Not Set"
Private Const PastDue As String = "Past Due"
Private Const DueThisYear As String = "Due This Year"
Private Const DueNextYear As String = "Due Next Year"
Private Const RemindThisMonth As String = "This Month"
Private Const RemindLastMonth As String = "Last Month"
Private Const Older As String = "Older"
Dim targetDate As DateTime = Nothing
Public Function DoesGroupContainRecord(ByVal groupByRecord As GroupByRecord, ByVal record As DataRecord) As Boolean Implements IGroupByEvaluator.DoesGroupContainRecord
Dim cellValue As Object = record.GetCellValue(groupByRecord.GroupByField)
Dim desc As String = groupByRecord.Description
' handle null values specially
If cellValue Is Nothing Or TypeOf cellValue Is DBNull Then
Return desc = NotSet
End If
' if the value is not a date time, just group them together
If TypeOf cellValue Is DateTime = False Then
Return True
End If
Return desc = GetDateLabel(CType(cellValue, DateTime), groupByRecord.GroupByField.Name)
End Function
Public Function GetGroupByValue(ByVal groupByRecord As GroupByRecord, ByVal record As DataRecord) As Object Implements IGroupByEvaluator.GetGroupByValue
Dim cellValue As Object = record.GetCellValue(groupByRecord.GroupByField)
Dim desc As String = String.Empty
Dim targetDate As DateTime = DateTime.MinValue
If cellValue Is Nothing Or TypeOf cellValue Is DBNull Then
desc = NotSet
ElseIf TypeOf cellValue Is DateTime Then
targetDate = CType(cellValue, DateTime)
desc = GetDateLabel(targetDate, groupByRecord.GroupByField.Name)
End If
groupByRecord.Description = desc
Return targetDate
End Function
Public ReadOnly Property SortComparer() As System.Collections.IComparer Implements IGroupByEvaluator.SortComparer
Get
Return Nothing
End Get
End Property
Private Function GetDateLabel(ByVal dt As DateTime, ByVal fldName As String) As String
Dim d As String = NotSet
Dim comparison As Integer = Nothing
Dim currentYear As Integer = DatePart(DateInterval.Year, Now)
'//If no date, return NotSet
If dt.Ticks = 0 Then
Return d
End If
'//Group by fieldname name
If fldName.ToLower = "form1duedate" Then
'//Past Due includes any records where the Form 1 Due Date is less than July 1st of the current year
Dim cDDate As New DateTime(currentYear, 7, 1)
comparison = dt.Date.CompareTo(cDDate.Date)
If comparison = 0 Then
d = DueThisYear
ElseIf comparison < 0 Then
d = PastDue
ElseIf comparison > 0 Then
d = DueNextYear
Else
d = NotSet
End If
ElseIf fldName.ToLower = "form1lastreminderdate" Then
Dim currentMonth As Integer = DatePart(DateInterval.Month, Now)
Dim olderThanDate As New DateTime(currentYear, currentMonth - 1, 1)
If dt.Date.Year = currentYear AndAlso dt.Date.Month = currentMonth Then
d = RemindThisMonth
ElseIf dt.Date.Year = currentYear AndAlso dt.Date.Month = currentMonth - 1 Then
d = RemindLastMonth
ElseIf dt.Date < olderThanDate Then
d = Older
Else
d = NotSet
End If
End If
Return d
End Function
End Class
#End Region
The majority of my code works other than the 'Calculate Totals' button. I have three listboxes and need my 'Calculate Totals' button to iterate through the selected costs in the 'lstCosts' listbox. However in Option Strict On I receive an error as "List is not a member of Double" and "ListCount is not a member of Double" Can someone help rectify this? I know my code is close to working I just don't know how.
Below is my code which isn't working:
Private Sub btnAddCourse_Click(sender As System.Object, e As System.EventArgs) Handles btnAddCourse.Click
'Declare variables
Dim strCourse As String 'To hold the Course Values
Dim strLocation As String 'To hold the Location values
'Item Indexing
'Identifies the four Course strings
strCourse = lstCourse.Items(0).ToString()
strCourse = lstCourse.Items(1).ToString()
strCourse = lstCourse.Items(2).ToString()
strCourse = lstCourse.Items(3).ToString()
'Identifies the four Location strings
strLocation = lstLocation.Items(0).ToString()
strLocation = lstLocation.Items(1).ToString()
strLocation = lstLocation.Items(2).ToString()
strLocation = lstLocation.Items(3).ToString()
If lstCourse.SelectedIndex = -1 Then
'Error Message for no course selected
MessageBox.Show("Select a course.", "Error", _
MessageBoxButtons.OK, MessageBoxIcon.Error)
ElseIf lstLocation.SelectedIndex = -1 Then
'Error message for no location selected
MessageBox.Show("Select a location.", "Error", _
MessageBoxButtons.OK, MessageBoxIcon.Error)
'Essential Linux and Belfast selected = £705
ElseIf lstCourse.SelectedIndex = 0 And lstLocation.SelectedIndex = 0 Then
lstCosts.Items.Add(705)
'Essential Linux and Coleraine selected = £600
ElseIf lstCourse.SelectedIndex = 0 And lstLocation.SelectedIndex = 1 Then
lstCosts.Items.Add(600)
'Essential Linux and Jordasntown selected = £600
ElseIf lstCourse.SelectedIndex = 0 And lstLocation.SelectedIndex = 2 Then
lstCosts.Items.Add(600)
'Essential Linux and Magee selected = £630
ElseIf lstCourse.SelectedIndex = 0 And lstLocation.SelectedIndex = 3 Then
lstCosts.Items.Add(630)
'Project Management and Belfast selected £520
ElseIf lstCourse.SelectedIndex = 1 And lstLocation.SelectedIndex = 0 Then
lstCosts.Items.Add(520)
'Project Management and Coleraine selected = £450
ElseIf lstCourse.SelectedIndex = 1 And lstLocation.SelectedIndex = 1 Then
lstCosts.Items.Add(450)
'Project Management and Jordanstown selected = £450
ElseIf lstCourse.SelectedIndex = 1 And lstLocation.SelectedIndex = 2 Then
lstCosts.Items.Add(450)
'Project Management and Magee selected = £470
ElseIf lstCourse.SelectedIndex = 1 And lstLocation.SelectedIndex = 3 Then
lstCosts.Items.Add(470)
'Overview of net and Belfast selected = £705
ElseIf lstCourse.SelectedIndex = 2 And lstLocation.SelectedIndex = 0 Then
lstCosts.Items.Add(705)
'Overview of net and Coleraine selected = £575
ElseIf lstCourse.SelectedIndex = 2 And lstLocation.SelectedIndex = 1 Then
lstCosts.Items.Add(575)
'Overview of net and Jordanstown selected = £575
ElseIf lstCourse.SelectedIndex = 2 And lstLocation.SelectedIndex = 2 Then
lstCosts.Items.Add(575)
'Overview of net and Magee selected = £605
ElseIf lstCourse.SelectedIndex = 2 And lstLocation.SelectedIndex = 3 Then
lstCosts.Items.Add(605)
'PHP and Belfast selected = £780
ElseIf lstCourse.SelectedIndex = 3 And lstLocation.SelectedIndex = 0 Then
lstCosts.Items.Add(780)
'PHP and Coleraine selected = £675
ElseIf lstCourse.SelectedIndex = 3 And lstLocation.SelectedIndex = 1 Then
lstCosts.Items.Add(675)
'PHP and Jordanstown selected = £675
ElseIf lstCourse.SelectedIndex = 3 And lstLocation.SelectedIndex = 2 Then
lstCosts.Items.Add(675)
'PHP and Magee selected = £705
ElseIf lstCourse.SelectedIndex = 3 And lstLocation.SelectedIndex = 3 Then
lstCosts.Items.Add(705)
End If
End Sub
Private Sub btnCalculateTotal_Click(sender As Object, e As EventArgs) Handles btnCalculateTotal.Click
Dim lstCosts As Double
Dim lblTotalCost As Double
For lstCosts = 0 To lstCosts.ListCount - 1
lblTotalCost = lblTotalCost + CDbl(lstCosts.List(lstCosts))
Next lstCosts
lblTotalCost = lstCosts
End Sub
Private Sub btnReset_Click(sender As Object, e As EventArgs) Handles btnReset.Click
'Clears the fields
lstCourse.ClearSelected()
lstLocation.ClearSelected()
lstCosts.Items.Clear()
lblTotalCost.Text = String.Empty
End Sub
Private Sub btnExit_Click(sender As Object, e As EventArgs) Handles btnExit.Click
'Closes the Program
Me.Close()
End Sub
when I Looked before there was more code to support my solution.
I think you have 2 issues local vs global naming, and assignment.
Private Sub btnCalculateTotal_Click(sender As Object, e As EventArgs) Handles btnCalculateTotal.Click
'Declare variables
Dim lvIterate As Double '
Dim lvTotalOfCost As Double
'Calculate Total Cost
For lvIterate = 0 To lstCosts.ListCount - 1
lvTotalOfCost = lvTotalOfCost + CDbl(lstCosts.List(lvIterate))
Next
lblTotalCost.Text = lvTotalOfCost
End Sub
Hope it solves you issue.
I'm dealing with a script and I won't be able to create it without your help.
This is what I need: I have two .txt files, one contains variables (between two #) like these:
#PickupFolder#=E:/SonicDataFiles/AR_INT/GPP_VE/IN
#Db1Url#=jdbc:sonic:sqlserver://CARASETMS:1433;databaseName=CRM
The other .txt have variables that need to be completed from the previous file
#Db1Url#=
#Db1Pwd#=
I need to get every variable in the first file (I guess I have to use regular expression) and replace its value in the second file if the variable exits.
I would really appreciate if anyone has a similar script to get an idea. I'm trying to do it with VBS.
Thanks a lot.
Gerardo.
Buenos Aires, Argentina.
This was my original script:
'ReplaceScript "c:\Variables_INT.txt" "C:\AR_INT.tailoring.properties"
'DEFINE CONSTANTS
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
'DEFINE VARIABLES
strTxtFile = Wscript.Arguments(0)
strTailoringFile = Wscript.Arguments(1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set WshShl = WScript.CreateObject("WScript.Shell")
Set objFileVariablesTXT = objFSO.OpenTextFile (strTxtFile, ForReading) 'Variables_INT.txt
Set objFileTailoring = objFSO.OpenTextFile (strTailoringFile, ForReading) 'AR_INT.tailoring.properties
Dim strQuartz, strPickupfFolder, strUrl, strDbPwd, strDbUser, strDbDestTable
strSearchString = objFileVariablesTXT.ReadAll
'SEARCH THE FILE FOR THE NEEDED DATA
vQuartz = InStr(strSearchString, "#QuartzJars#=")
vPickupFolder = InStr(strSearchString, "#PickupFolder#=")
vDbUrl = InStr(strSearchString, "#Db1Url#=")
vDbPwd = InStr(strSearchString, "#Db1Pwd#=")
vDbUser = InStr(strSearchString, "#Db1User#=")
vDbDestTable = InStr(strSearchString, "#DestinationTable#=")
'PARSE OUT THE NEEDED INFO
If vQuartz <> 0 Then
'vQuartz = vQuartz + 13
strQuartz = Mid(strSearchString, vQuartz, 304)
' WScript.Echo strQuartz
End If
If vPickupFolder <> 0 Then
'vPickupFolder = vPickupFolder + 15
strPickupfFolder = Mid(strSearchString, vPickupFolder, 50)
' WScript.Echo strPickupfFolder
End If
If vDbUrl <> 0 Then
'vDbUrl = vDbUrl + 9
strUrl = Mid(strSearchString, vDbUrl, 65)
' WScript.Echo strUrl
End If
If vDbPwd <> 0 Then
'vDbPwd = vDbPwd + 9
strDbPwd = Mid(strSearchString, vDbPwd, 17)
'WScript.Echo strDbPwd
End If
If vDbUser <> 0 Then
'vDbUser = vDbUser + 10
strDbUser = Mid(strSearchString, vDbUser, 25)
'WScript.Echo strDbUser
End If
If vDbDestTable <> 0 Then
'vDbDestTable = vDbDestTable + 19
strDbDestTable = Mid(strSearchString, vDbDestTable, 29)
'WScript.Echo strDbDestTable
End If
objFileVariablesTXT.Close
strReplaceString = objFileTailoring.ReadAll
arrReplacements = Array("#QuartzJars#=Ç" & strQuartz , "#PickupFolder#=Ç" & strPickupfFolder, "#Db1Url#=Ç" & strUrl, "#Db1Pwd#=Ç" & strDbPwd, "#Db1User#=Ç" &strDbUser, "#DestinationTable#=Ç" & strDbDestTable)
objFileTailoring.Close
Set objFileTailoring = Nothing
For Each strReplacement In arrReplacements
strReplaceWhat = Split(strReplacement, "Ç")(0)
'WScript.Echo strReplaceWhat
strReplaceWith = Split(strReplacement, "Ç")(1)
'WScript.Echo strReplaceWith
strReplaceString = Replace(strReplaceString, strReplaceWhat, strReplaceWith)
Next
'wScript.Echo strReplaceString
Set objFileTailoring = objFSO.OpenTextFile(strTailoringFile, 2, true)
objFileTailoring.Write strReplaceString
objFileTailoring.Close
Quick and Dirty:
Dim sFSpec1 : sFSpec1 = "..\data\frs.txt"
Dim sFSpec2 : sFSpec2 = "..\data\sec.txt"
Dim dicRpl : Set dicRpl = CreateObject( "Scripting.Dictionary" )
Dim reCut : Set reCut = New RegExp
reCut.Global = True
reCut.Pattern = "(#[^#]+#)\s*=\s*(.*?)\s*$"
Dim sAll : sAll = goFS.OpenTextFile( sFSpec1 ).ReadAll
WScript.Echo sAll
WScript.Echo "---------------"
Dim oMTS : Set oMTS = reCut.Execute( sAll )
Dim oMT
For Each oMT In oMTS
dicRpl( oMT.SubMatches( 0 ) ) = oMT.SubMatches( 1 )
Next
sAll = goFS.OpenTextFile( sFSpec2 ).ReadAll
WScript.Echo sAll
WScript.Echo "---------------"
Dim sKey
For Each sKey In dicRpl.Keys
sAll = Replace( sAll, sKey, dicRpl( sKey ) )
Next
WScript.Echo sAll
output:
#PickupFolder#=E:/SonicDataFiles/AR_INT/GPP_VE/IN
#Db1Url#=jdbc:sonic:sqlserver://CARASETMS:1433;databaseName=CRM
---------------
#Db1Url#=
#Db1Pwd#=
---------------
jdbc:sonic:sqlserver://CARASETMS:1433;databaseName=CRM=
#Db1Pwd#=
If that solves your problem in principle, we can nail down details.
ADDED:
As Jean-François Corbett surely is right, use the pattern
reCut.Pattern = "(#[^#]+#=)(.*?)\s*$"
and the final replacement
sAll = Replace( sAll, sKey, sKey & dicRpl( sKey ) )
This version assumes a strict #x#=[y] format in both files.
Tested this brute force approach, it works for me...
Dim FSO, txs, all, sourceLines, i, targetLines, j, delimiterPosition
Set FSO = CreateObject("Scripting.FileSystemObject")
set txs = FSO.OpenTextFile(".\source.txt", 1)
all=txs.ReadAll
txs.Close
sourceLines=Split(all,vbCrLf)
set txs = FSO.OpenTextFile(".\target.txt", 1)
all=txs.ReadAll
txs.Close
targetLines=Split(all,vbCrLf)
for i = 0 to ubound(sourceLines)
If sourceLines(i)<>"" Then
delimiterPosition = InStr(2, sourceLines(i), "#")
sourceVarName = Mid(sourceLines(i), 2, delimiterPosition - 2)
sourceVarValue = Mid(sourceLines(i), delimiterPosition + 2)
for j = 0 to ubound(targetLines)
If targetLines(j)<>"" Then
delimiterPosition = InStr(2, targetLines(j), "#")
targetVarName = Mid(targetLines(j), 2, delimiterPosition - 2)
If targetVarName = sourceVarName Then
targetLines(j) = targetLines(j) & sourceVarValue
End If
End If
next
End If
next
set txs = FSO.OpenTextFile(".\target.txt", 2)
for j = 0 to ubound(targetLines)
txs.WriteLine targetLines(j)
next
txs.Close
Target file is now:
#Db1Url#=jdbc:sonic:sqlserver://CARASETMS:1433;databaseName=CRM
#Db1Pwd#=