'' Èo treba dorobi?:
''
'' - kontrolu èi nechcem importova? už naimportované dáta
''
''
''
''
''
''
''
Dim WITPAEPath, TMPPath, BATPath As String
Dim ActionDate As Date
Dim ImportFromDate, ImportToDate As Date
Dim ScenNo, Side As String
Sub MakeBAT()
Dim fs, f
Dim Line As String
Line = "witploadAE.exe" & "/s" & ScenNo & " /e /b,"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(BATPath, 8, True, 0)
f.Writeline ("c:")
f.Writeline ("cd " + WITPAEPath + "\SCEN")
f.Writeline (Line)
f.Close
End Sub
Sub DelBAT()
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
fs.DeleteFile BATPath
End Sub
Sub DeleteSheet(strSheetName As String)
' deletes a sheet named strSheetName in the active workbook
Application.DisplayAlerts = False
Sheets(strSheetName).Delete
Application.DisplayAlerts = True
End Sub
Sub ImportDataWorksheets()
Dim LastRow As Double
Dim FileName, BookName, SheetName As String
Dim MyBookName As String
''DeleteSheet ("Classes")
''DeleteSheet ("Ships")
SheetName = "witpcls" + ScenNo
BookName = SheetName + ".csv"
FileName = WITPAEPath + "\SCEN\" + BookName
MyBookName = ActiveWorkbook.Name
Workbooks.Open (FileName), , , 2
Workbooks(BookName).Sheets(1).Copy _
After:=Workbooks(MyBookName).Sheets("AUX")
Workbooks(BookName).Close SaveChanges:=False
Worksheets(SheetName).Name = "Classes"
SheetName = "witpshp" + ScenNo
BookName = SheetName + ".csv"
FileName = WITPAEPath + "\SCEN\" + SheetName
Workbooks.Open (FileName), , , 2
Workbooks(BookName).Sheets(1).Copy _
After:=Workbooks(MyBookName).Sheets("AUX")
Workbooks(BookName).Close SaveChanges:=False
Worksheets(SheetName).Name = "Ships"
Call PrepareShipsDB
DeleteSheet ("Classes")
DeleteSheet ("Ships")
End Sub
Sub PrepareShipsDB()
Dim MyWrkSht As Worksheet
Dim MyRange As Range
Dim i, j, LastRow, LastRowClasses As Double
Dim s As String
Dim MyVarA, MyVarB
' Clear all Cells in ShipsDB to prepare sheet to new data
LastRow = GetLastRow("ShipsDB")
s = "A2:" & "K" & CStr(LastRow)
Set MyWrkSht = ActiveWorkbook.Worksheets("ShipsDB")
Set MyRange = MyWrkSht.Range(s)
MyRange.ClearContents
LastRowClasses = GetLastRow("Classes")
LastRow = GetLastRow("Ships")
i = 2
j = 2
Do While i <= LastRow
If ActiveWorkbook.Worksheets("Ships").Cells(i, 3) <> 0 Then
'' SHIP ID
MyWrkSht.Cells(j, 1).Value = ActiveWorkbook.Worksheets("Ships").Cells(i, 1)
'' SHIP NAME
MyWrkSht.Cells(j, 2).Value = ActiveWorkbook.Worksheets("Ships").Cells(i, 2)
'' CLASS ID
MyWrkSht.Cells(j, 3).Value = ActiveWorkbook.Worksheets("Ships").Cells(i, 3)
'' NATIONALITY ID
MyWrkSht.Cells(j, 4).Value = ActiveWorkbook.Worksheets("Ships").Cells(i, 15)
'' NATIONALITY
MyVarA = Application.WorksheetFunction.Match(MyWrkSht.Cells(j, 4).Value, Worksheets("AUX").Range("D2:D19"))
MyVarB = Application.WorksheetFunction.HLookup("Nationality", Worksheets("AUX").Range("E2:E19"), MyVarA)
MyWrkSht.Cells(j, 5).Value = MyVarB
'' Type ID
s = "A2:A" & CStr(LastRowClasses)
MyVarA = Application.WorksheetFunction.Match(MyWrkSht.Cells(j, 3).Value, Worksheets("Classes").Range(s))
MyWrkSht.Cells(j, 6).Value = ActiveWorkbook.Worksheets("Classes").Cells(MyVarA + 1, 3).Value
'' Type
MyVarA = Application.WorksheetFunction.Match(MyWrkSht.Cells(j, 6).Value, Worksheets("AUX").Range("A2:A84"))
MyVarB = Application.WorksheetFunction.HLookup("Type", Worksheets("AUX").Range("B2:B84"), MyVarA)
MyWrkSht.Cells(j, 7).Value = MyVarB
'' Full Name
s = MyWrkSht.Cells(j, 7).Value & " " & MyWrkSht.Cells(j, 2).Value
MyWrkSht.Cells(j, 8).Value = s
'' Tonnage
s = "A2:A" & CStr(LastRowClasses)
MyVarA = Application.WorksheetFunction.Match(MyWrkSht.Cells(j, 3).Value, Worksheets("Classes").Range(s))
MyWrkSht.Cells(j, 9).Value = ActiveWorkbook.Worksheets("Classes").Cells(MyVarA + 1, 22).Value
j = j + 1
End If
i = i + 1
Loop
''MyWrkSht.Range(s).FormatConditions
Set MyRange = Nothing
Set MyWrkSht = Nothing
End Sub
Sub LoadConfig()
WITPAEPath = Worksheets("Configuration").Cells(3, 3).Value
TMPPath = Worksheets("Configuration").Cells(4, 3).Value + "\RCMTMP.txt"
BATPath = Worksheets("Configuration").Cells(3, 3).Value + "\SCEN\DUMPSCEN.bat"
ImportFromDate = Worksheets("Configuration").Cells(5, 3).Value
ImportToDate = Worksheets("Configuration").Cells(6, 3).Value
ScenNo = Worksheets("Configuration").Cells(7, 3).Value
Side = Worksheets("Configuration").Cells(8, 3).Value
End Sub
Sub LoadDB()
Dim RetVar
Dim ImWrkSht As Worksheet
Dim ImRange As Range
Dim MsgBoxResponse As String
LoadConfig
MakeBAT
RetVar = Shell(BATPath, vbNormalFocus)
MsgBoxResponse = MsgBox("Wait for dumping end, then press OK", vbOKOnly)
DelBAT
ImportDataWorksheets
End Sub
Function GetLastRow(WrkShtName As String) As Double
Dim MyWrkSht As Worksheet
Dim MyRange As Range
Set MyWrkSht = ActiveWorkbook.Worksheets(WrkShtName)
Set MyRange = MyWrkSht.UsedRange
GetLastRow = MyRange.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set MyRange = Nothing
Set MyWrkSht = Nothing
End Function
Sub ImportReport()
Dim Path As String
LoadConfig
Path = WITPAEPath + "\SAVE\combatreport2.txt"
OpenCombatReport (Path)
Path = WITPAEPath + "\SAVE\" & Side & "operationsreport2.txt"
OpenOperationsReport (Path)
Call RemoveDuplicates
Call RefreshPivotTables
End Sub
Sub RemoveDuplicates()
Dim MyWrkSht As Worksheet
Dim MyRange As Range
Dim a
Set MyWrkSht = ActiveWorkbook.Worksheets("Combat Reports")
Set MyRange = MyWrkSht.UsedRange
MyRange.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes
Set MyRange = Nothing
Set MyWrkSht = Nothing
End Sub
Sub RefreshPivotTables()
Dim s As String
Dim LastRow As Double
LastRow = GetLastRow("Combat Reports")
s = "Combat Reports!R1C1:R" & CStr(LastRow) & "C7"
ActiveWorkbook.Worksheets("MONTHS").PivotTables("MonthReview").SourceData = s
ActiveWorkbook.Worksheets("MONTHS").PivotTables("SubmarineReview").SourceData = s
ActiveWorkbook.Worksheets("MONTHS").PivotTables("MonthReview").RefreshTable
ActiveWorkbook.Worksheets("MONTHS").PivotTables("SubmarineReview").RefreshTable
End Sub
Sub OpenOperationsReport(ORPath As String)
Dim fs, f
Dim LastRow As Double
Dim ShipName As String
Dim SunkDate As Date
Dim MyLine
Dim s As String
Dim MyWrkSht As Worksheet
Dim MyRange As Range
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(ORPath, 1, 0)
MyLine = ""
Set MyWrkSht = ActiveWorkbook.Worksheets("Combat Reports")
Set MyRange = MyWrkSht.UsedRange
LastRow = GetLastRow("Combat Reports")
Do While f.AtEndOfStream = False
MyLine = f.Readline
If InStr(1, MyLine, "reported to have been sunk", vbTextCompare) > 0 Then
ShipName = GetSunkShipName(MyLine)
SunkDate = GetSunkShipDate(MyLine)
Set MyRange = MyWrkSht.Rows(1)
i = 2
Do While i <= LastRow
If MyWrkSht.Cells(i, 1).Value = SunkDate Then
If MyWrkSht.Cells(i, 4).Value = ShipName Then
MyWrkSht.Cells(i, 6).Value = "SUNK"
i = LastRow
End If
End If
i = i + 1
Loop
End If
If InStr(1, MyLine, "Previous report of sinking", vbTextCompare) > 0 Then
ShipName = GetFalseReportedShipName(MyLine)
''SunkDate = GetSunkShipDate(MyLine)
Set MyRange = MyWrkSht.Rows(1)
i = LastRow
Do While (MyWrkSht.Cells(i, 4).Value <> ShipName) And (i > 1)
i = i - 1
Loop
If MyWrkSht.Cells(i, 4).Value = ShipName Then MyWrkSht.Cells(i, 6).Value = "FR SUNK"
End If
Loop
f.Close
End Sub
Function GetSunkShipName(MyLine) As String
Dim i As Long
i = InStr(1, MyLine, "is reported", vbTextCompare) - 2
GetSunkShipName = Left(MyLine, i)
End Function
Function GetShipShortName(LongShipName As String) As String
Dim i As Double
i = InStr(LongShipName, " ")
GetShipShortName = Right(LongShipName, Len(LongShipName) - i)
End Function
Function GetFalseReportedShipName(MyLine) As String
Dim i, j As Long
Dim s As String
i = InStr(1, MyLine, "of sinking of", vbTextCompare) + 13
j = Len(MyLine)
s = Right(MyLine, j - i)
i = InStr(1, s, "incorrect", vbTextCompare) - 2
GetFalseReportedShipName = Left(s, i)
End Function
Function GetSunkShipDate(ShipLine) As Date
Dim sDate As String
Dim s, sDay, sMonth, sYear As String
sDate = Right(ShipLine, 12)
sYear = Right(sDate, 4)
sDay = Mid(sDate, 5, 2)
sMonth = GetMonth(Left(sDate, 3))
s = sDay + "." + sMonth + "." + sYear
GetSunkShipDate = DateValue(s)
End Function
Sub ImportArchiveReports()
Dim ArchivePath, Path As String
Dim m As Integer
Dim YY, MM, DD, s As String
Dim iDay As Date
LoadConfig
ArchivePath = Worksheets("Configuration").Cells(3, 3).Value + "\SAVE\archive"
iDay = ImportFromDate
'' Sem by mala ešte prís? kontrola, èi už reporty z daného dátumu neboli naimportované
Do While iDay <= ImportToDate
DD = Day(iDay)
If Len(DD) < 2 Then DD = "0" & DD
m = Month(iDay)
If m < 10 Then
MM = "0" & CStr(m)
Else: MM = CStr(m)
End If
YY = Year(iDay)
YY = Right(YY, 2)
Path = ArchivePath + "\combatreport_" + CStr(YY) + CStr(MM) + CStr(DD) + ".txt"
If Dir(Path) <> "" Then OpenCombatReport (Path)
Path = ArchivePath & "\" & Side & "operationsreport_" + CStr(YY) + CStr(MM) + CStr(DD) + ".txt"
If Dir(Path) <> "" Then OpenOperationsReport (Path)
iDay = iDay + 1
Loop
Call RemoveDuplicates
Call RefreshPivotTables
End Sub
Sub OpenCombatReport(ReportPath As String)
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim tf, fs, f
Dim Path, Line As String
Dim i As Integer
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(ReportPath, 1, 0)
Set tf = fs.OpenTextFile(TMPPath, 8, True, 0)
i = 1
ParserStream = ""
Do While f.AtEndOfStream = False
Line = f.Readline
If Line = "--------------------------------------------------------------------------------" Then
' call parser Sub with ParserStream argument
tf.Close
ParseModule (TMPPath)
fs.DeleteFile (TMPPath)
Set tf = fs.OpenTextFile(TMPPath, 8, True, 0)
Else
If IsNewDay(Line) Then ActionDate = GetDayDate(Line)
tf.Writeline (Line)
End If
i = i + 1
Loop
Worksheets("Configuration").Cells(10, 3).Value = ActionDate
f.Close
End Sub
Function IsNewDay(s As String) As Boolean
If Mid(s, 1, 12) = "AFTER ACTION" Then
IsNewDay = True
Else: IsNewDay = False
End If
End Function
Function GetDayDate(DateLine As String) As Date
Dim LineL As Integer
Dim s, sMonth, sDay, sYear As String
LineL = Len(DateLine)
s = Mid(DateLine, LineL - 9, 10)
sMonth = GetMonth(Mid(s, 1, 3))
sDay = Mid(s, 5, 2)
sYear = Mid(s, 9, 2)
s = sDay + "." + sMonth + "." + "19" + sYear
GetDayDate = DateValue(s)
End Function
Sub ParseModule(TMPPath As String)
Dim Line, Ship As String
Dim fs, f
Dim arr
Dim s
Dim RowB, RowD As String
Dim JapArr(15) As String
Dim AllArr(15) As String
Dim i As Integer
Dim LastRow&
Dim isJapAttacker As Boolean
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(TMPPath, 1, 0)
Line = f.Readline
i = 0
isJapAttacker = False
Select Case Mid(Line, 1, 3)
Case "Sub"
' Parse Ship Names from rcm_tmp.txt to JappArr and AllArr collections of ship names
Do While f.AtEndOfStream = False
Line = f.Readline
If InStr(Line, "Japanese Ships") > 0 Then
Do Until Line = " "
Line = f.Readline
arr = Split(Line, ",", , 1)
If (UBound(arr) > 0 Or InStr(Line, "SS")) Then
Ship = arr(0)
Ship = Mid(Ship, 7)
JapArr(i) = Ship
' if Jap ship is SS then set isJapAttacker as true
If InStr(Line, "SS") Then isJapAttacker = True
i = i + 1
End If
Loop
i = 0
End If
If InStr(Line, "Allied Ships") > 0 Then
Do Until Line = " "
Line = f.Readline
arr = Split(Line, ",", , 1)
If (UBound(arr) > 0 Or InStr(Line, "SS")) Then
Ship = arr(0)
Ship = Mid(Ship, 7)
AllArr(i) = Ship
' if isJapAttacker is set as true (jap ship was SS) AND Allied ship is SS then if Allied ship is NOT damaged then isJapAttacker set to false
If isJapAttacker Then
If (UBound(arr) = 0 And InStr(Line, "SS")) Then isJapAttacker = False
End If
i = i + 1
End If
Loop
End If
Loop
If isJapAttacker Then
i = 0
Do While AllArr(i) <> ""
Call WriteCRRow(ActionDate, JapArr(0), AllArr(i))
i = i + 1
Loop
Else
i = 0
Do While JapArr(i) <> ""
Call WriteCRRow(ActionDate, AllArr(0), JapArr(i))
i = i + 1
Loop
End If
isJapAttacker = False
Case "ASW"
Do While f.AtEndOfStream = False
Line = f.Readline
If InStr(Line, "Japanese Ships") > 0 Then
Do Until Line = " "
Line = f.Readline
arr = Split(Line, ",", , 1)
If (UBound(arr) > 0 Or InStr(Line, "SS")) Then
Ship = arr(0)
Ship = Mid(Ship, 7)
JapArr(i) = Ship
' if Jap ship is SS then set isJapAttacker as true
If InStr(Line, "SS") Then isJapAttacker = True
i = i + 1
End If
Loop
i = 0
End If
If InStr(Line, "Allied Ships") > 0 Then
Do Until Line = " "
Line = f.Readline
arr = Split(Line, ",", , 1)
If (UBound(arr) > 0 Or InStr(Line, "SS")) Then
Ship = arr(0)
Ship = Mid(Ship, 7)
AllArr(i) = Ship
' if isJapAttacker is set as true (jap ship was SS) AND Allied ship is SS then if Allied ship is NOT damaged then isJapAttacker set to false
If isJapAttacker Then
If (UBound(arr) = 0 And InStr(Line, "SS")) Then isJapAttacker = False
End If
i = i + 1
End If
Loop
End If
Loop
If isJapAttacker Then
i = 0
Do While AllArr(i) <> ""
Call WriteCRRow(ActionDate, JapArr(0), AllArr(i))
i = i + 1
Loop
Else
i = 0
Do While JapArr(i) <> ""
Call WriteCRRow(ActionDate, AllArr(0), JapArr(i))
i = i + 1
Loop
End If
isJapAttacker = False
Case Else
End Select
i = 0
f.Close
End Sub
Function GetMonth(ParsedDateString As String) As String
Select Case ParsedDateString
Case "Jan"
GetMonth = "01"
Case "Feb"
GetMonth = "02"
Case "Mar"
GetMonth = "03"
Case "Apr"
GetMonth = "04"
Case "May"
GetMonth = "05"
Case "Jun"
GetMonth = "06"
Case "Jul"
GetMonth = "07"
Case "Aug"
GetMonth = "08"
Case "Sep"
GetMonth = "09"
Case "Oct"
GetMonth = "10"
Case "Nov"
GetMonth = "11"
Case "Dec"
GetMonth = "12"
End Select
End Function
Private Sub WriteCRRow(RowA As Date, RowB As String, RowD As String)
Dim MyWrkSht As Worksheet
Dim MyRange As Range
Dim LastRow&, LastRowShipsDB
Dim s, ss As String
Dim MyVarA, i As Double
Dim err As Variant
Set MyWrkSht = ActiveWorkbook.Worksheets("Combat Reports")
Set MyRange = MyWrkSht.UsedRange
LastRow = MyRange.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRowShipsDB = GetLastRow("ShipsDB")
s = "H1:H" & CStr(LastRowShipsDB)
MyVarA = Application.WorksheetFunction.Match(RowB, Worksheets("ShipsDB").Range(s), 0)
i = ActiveWorkbook.Worksheets("ShipsDB").Cells(MyVarA, 4).Value
If (Side = "a" And i > 3) Or (Side = "j" And i < 3) Then
'' Date
MyWrkSht.Cells(LastRow + 1, 1).Value = RowA
'' Long Submarine Name
MyWrkSht.Cells(LastRow + 1, 2).Value = RowB
'' Submarine Nation
MyWrkSht.Cells(LastRow + 1, 3).Value = ActiveWorkbook.Worksheets("ShipsDB").Cells(MyVarA, 5).Value
'' Long Victim Name
MyWrkSht.Cells(LastRow + 1, 4).Value = RowD
'' Tonnage
'' if ship type is same MATCH then write tonnage
s = "H1:H" & CStr(LastRowShipsDB)
err = Application.Match(RowD, Worksheets("ShipsDB").Range(s), 0)
If IsError(err) Then
s = "B1:B" & CStr(LastRowShipsDB)
ss = GetShipShortName(RowD)
MyVarA = Application.Match(ss, Worksheets("ShipsDB").Range(s), 0)
MyWrkSht.Cells(LastRow + 1, 5).Value = ActiveWorkbook.Worksheets("ShipsDB").Cells(MyVarA, 9).Value
'' If ship type is diferent then lookup next short name match
Else
s = "H1:H" & CStr(LastRowShipsDB)
MyVarA = Application.Match(RowD, Worksheets("ShipsDB").Range(s), 0)
MyWrkSht.Cells(LastRow + 1, 5).Value = ActiveWorkbook.Worksheets("ShipsDB").Cells(MyVarA, 9).Value
End If
MyWrkSht.Cells(LastRow + 1, 6).Value = "DAMAGED"
If Len(Month(RowA)) < 2 Then
ss = Year(RowA) & "/0" & Month(RowA)
Else: ss = Year(RowA) & "/" & Month(RowA)
End If
MyWrkSht.Cells(LastRow + 1, 7).Value = ss
End If
Set MyRange = Nothing
Set MyWrkSht = Nothing
End Sub