The biggest reason for me writing this is as a learning experience. I am
sure that there is a more elegant way to write this but there is only one way
to become a better programmer….
If you run this you will see a message box that shows “Array Size Neededâ€
vs. “Array Size Usedâ€. Looks like this is totally unneeded but was
interesting for me.
The code is still beta….
Thanks for the feedback,
Bob
'Pred2Name Version 1.0 by Bob Inwater of P.P.S. 04/08/05
Option Explicit
Dim SomeText, StrLength, SingleChr, SingleChrASC, Result, OutPutNum,
OutPutNumOne As Variant
Dim RemovePlaces As Integer
Dim OutPutText As String
Dim OutPutTextone As String
Dim XArray() As Variant
Dim GetPredCount As Integer
Dim SwapCount As Integer
Dim XportCount As Integer
Dim TrimCount As Integer
Dim TrimmerCount As Integer
Dim MaryCounter As Integer
Dim ResultOne As Variant
Dim CommaFound As Boolean
Dim Count As Integer
Dim Final As Variant
Dim CountTwo As Integer
Dim Joiner As String
Dim JoinerTwo As String
Dim NoCommas() As Integer
Dim JoinedOutPut As Variant
Dim t As Task
Dim r As Integer
Dim PredNum() As Variant
Dim PredDataOut() As Variant
Dim RawNums As String
Dim TNames() As Variant
Dim TTotal As Variant
Dim PredNumVal As Variant
Dim FindCode As Variant
Dim PredOutName As String
Dim ChrCount As Integer
Dim CountMembers As Integer
Dim MaxMembers As Integer
Dim ArrayDepth As Integer
Sub Master()
Depth
Imports
SwapPredData
Export
messages
End Sub
Sub Depth()
'******************************* This sets the depth of the
ArrayDepth = 10 '************** Arrays.
'*******************************
End Sub
Sub Imports()
TTotal = ActiveProject.Tasks.Count
ReDim PredNum(0 To TTotal) As Variant
ReDim TNames(1 To TTotal) As Variant
For Each t In ActiveProject.Tasks
r = t.ID
TNames(r) = t.Name
PredNum(r) = t.Predecessors
Next t
MaxMembers = 0
End Sub
Sub SwapPredData()
For SwapCount = 1 To TTotal
SomeText = PredNum(SwapCount)
POP
Next SwapCount
End Sub
Sub POP()
StrLength = Len(SomeText)
GetPred
TrimCount = 1
Trimmer
End Sub
Sub GetPred()
CommaFound = False
Result = ""
StrLength = Len(SomeText)
For GetPredCount = 1 To StrLength
SingleChrASC = Asc(Mid(SomeText, GetPredCount, 1))
SingleChr = (Mid(SomeText, GetPredCount, 1))
If CommaFound = False Then
If SingleChrASC = 44 Then
CommaFound = True
ElseIf CommaFound = False Then
ResultOne = SingleChr
Result = Result & ResultOne
End If
End If
Next GetPredCount
End Sub
Sub Trimmer()
CommaFound = False
StrLength = Len(Result)
GetClear
For TrimmerCount = 1 To StrLength
SingleChrASC = Asc(Mid(Result, TrimmerCount, 1))
SingleChr = (Mid(Result, TrimmerCount, 1))
If SingleChrASC < 59 And SingleChrASC > 48 And CommaFound =
False Then
CommaFound = False
OutPutNumOne = SingleChr
OutPutNum = OutPutNum & OutPutNumOne
Else: CommaFound = True
End If
If CommaFound = True Then
OutPutTextone = SingleChr
OutPutText = OutPutText & OutPutTextone
End If
Next TrimmerCount
On Error Resume Next
If StrLength > 0 Then
' ********************************************************
ReDim Preserve XArray(1 To TTotal, 1 To ArrayDepth) 'Need to address
max array size
PredOutName = TNames(OutPutNum)
XArray(SwapCount, TrimCount) = PredOutName + " " + OutPutText
CountMembers = CountMembers + 1
If CountMembers > MaxMembers Then
MaxMembers = CountMembers
End If
' ********************************************************
RemovePlaces = Len(SomeText) - StrLength
If RemovePlaces = 0 Then
StrLength = 0
SomeText = ""
ElseIf RemovePlaces <> 0 Then
RemovePlaces = RemovePlaces - 1
End If
If RemovePlaces >= 1 Then
SomeText = Right(SomeText, RemovePlaces)
End If
End If
BackandForth
CountMembers = 1
End Sub
Sub BackandForth()
TrimCount = TrimCount + 1
If SomeText <> "" Then
GetPred
Trimmer
End If
MaryCounter = MaryCounter + 1
If MaryCounter > 2000 Then
HailMary
MaryCounter = 0
End If
End Sub
Sub GetClear()
OutPutNumOne = ""
OutPutNum = ""
OutPutTextone = ""
OutPutText = ""
Final = ""
JoinerTwo = ""
End Sub
Sub Export()
For Each t In ActiveProject.Tasks
r = t.ID
For XportCount = 1 To ArrayDepth
Joiner = XArray(r, XportCount)
If Joiner <> "" Then
JoinerTwo = Joiner & "/" & JoinerTwo
Final = JoinerTwo
End If
Next XportCount
If Len(Final) > 250 Then ' need noteation or
msgbox
MsgBox "Please be aware that only the first 250
characters of your Task Name output will be displayed."
Final = Left(Final, 250)
'HailMary
End If
t.Text9 = Final
GetClear
Next t
End Sub
Sub HailMary() ' this is my Dev "Save my Butt Code"
Dim Bailout As Integer
Bailout = MsgBox("Is there an ERROR? Click NO to escape or YES to
continue.", vbYesNo)
If Bailout = 7 Then
End
End If
End Sub
Sub messages()
If ArrayDepth < MaxMembers Then
MsgBox ("You used as many as " & MaxMembers & " Predecessors per task. This
Software was sized for only: " & ArrayDepth & ". Please have a tech re-adjust
this software for your Schedule. ")
ElseIf (ArrayDepth * 1.5) > MaxMembers Then
MsgBox ("You used as many as " & MaxMembers & " Predecessors per task. This
Software was sized for : " & ArrayDepth & ". If this Software seems slow have
a tech re-adjust the software for your Schedule. ")
End If
End Sub
