'*****************************************
'Versionshinweise aus den Dateien holen
'Andreas Hänsch
'www.ksah.eu
'info@ksah.eu
'*****************************************

Option Explicit

#Const cDebug = False

Const cTrenner = "<|>"
Const cLaengeBenutzer = 15
Const cAktPC = "Dieser PC"
Const cHeute = "Heute um"
Const cKlammerAuf = ">>>"
Const cKlammerZu = "<<<"

Const cUrsprung = "OriginProfileFeature"
Const cVerknuepfung = "MateGroup"

Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swFeat As SldWorks.Feature
    Dim vVerStr As Variant
    Dim vSplit As Variant
    Dim i As Integer
    Dim j As Integer
    Dim strAusgEins As String
    Dim strAusgZwei As String
    Dim strHilfe As String
    Dim strErstellt() As String
    Dim bKlammer As Boolean

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then Exit Sub
    
    Set swFeat = swModel.FirstFeature

    strAusgEins = "Datei : " + swModel.GetPathName + vbCr + vbCr

    If IsEmpty(vVerStr) Then
       vVerStr = swApp.VersionHistory(swModel.GetPathName)
    End If
    
    strAusgEins = strAusgEins + "Datei wurde konvertiert von:" + vbCr
    strAusgEins = strAusgEins + "Version [Ausgabedatum der Version]" + vbCr
    
    If Not IsEmpty(vVerStr) Then
        For i = 0 To UBound(vVerStr)
#If cDebug Then
            Debug.Print vVerStr(i)
#End If
            strAusgEins = strAusgEins + ConvertFileVersionToSwMajorVersion(Left(vVerStr(i), InStr(vVerStr(i), "[") - 1))
            strAusgEins = strAusgEins + " ["
            strHilfe = Mid(vVerStr(i), InStr(vVerStr(i), "[") + 1)
            strHilfe = Left(strHilfe, Len(strHilfe) - 1)
            vSplit = Split(strHilfe, ",")
                For j = 0 To UBound(vSplit)
                    strAusgEins = strAusgEins + ConvertDatum(CStr(vSplit(j)))
                    If j <> UBound(vSplit) Then
                        strAusgEins = strAusgEins + ", "
                    End If
                Next
            strAusgEins = strAusgEins + "]" + vbCr
        Next
    Else
        strAusgEins = strAusgEins + "Keine Information gespeichert." + vbCr
    End If
    
    strAusgEins = strAusgEins + vbCr
    strAusgEins = strAusgEins + "Variablen:" + vbCr
    strAusgEins = strAusgEins + "Titel                     = " + swModel.SummaryInfo(swSumInfoTitle) + vbCr
    strAusgEins = strAusgEins + "Subjekt               = " + swModel.SummaryInfo(swSumInfoSubject) + vbCr
    strAusgEins = strAusgEins + "Autor                   = " + swModel.SummaryInfo(swSumInfoAuthor) + vbCr
    strAusgEins = strAusgEins + "Keywords            = " + swModel.SummaryInfo(swSumInfoKeywords) + vbCr
    strAusgEins = strAusgEins + "Kommentar         = " + swModel.SummaryInfo(swSumInfoComment) + vbCr
    strAusgEins = strAusgEins + "Gespeichert von = " + IsDieserPC(swModel.SummaryInfo(swSumInfoSavedBy)) + vbCr
    strAusgEins = strAusgEins + "Erstellt    am        = " + DatumIsHeute(swModel.SummaryInfo(swSumInfoCreateDate)) + vbCr
    strAusgEins = strAusgEins + "Gespeichert am  = " + DatumIsHeute(swModel.SummaryInfo(swSumInfoSaveDate)) + vbCr
    strAusgEins = strAusgEins + vbCr

    strAusgZwei = "Feature wurden von welchen Benutzern erstellt:" + vbCr
    
    If swModel.GetType() <> swDocDRAWING Then
        strAusgZwei = strAusgZwei + "Vorlage und Grunddaten:" + vbCr
    End If

    ReDim strErstellt(0)
    
    'strErstellt(0) = swFeat.CreatedBy + cTrenner + swFeat.DateCreated

    
    Do While Not swFeat Is Nothing
        For i = 0 To UBound(strErstellt)
            If strErstellt(i) <> "" Then
                If Left(strErstellt(i), InStr(strErstellt(i), cTrenner) - 1) = swFeat.CreatedBy Or swFeat.CreatedBy = "" Or swFeat.GetTypeName2 = cVerknuepfung Then
                    GoTo Ueberspringen
                End If
            End If
        Next
        
        If strErstellt(UBound(strErstellt)) <> "" Then
            ReDim Preserve strErstellt(UBound(strErstellt) + 1)
        End If
        strErstellt(UBound(strErstellt)) = swFeat.CreatedBy + cTrenner + swFeat.DateCreated
Ueberspringen:
        If swFeat.GetTypeName2 = cUrsprung Then
            strAusgZwei = strAusgZwei + Ausgabe(strErstellt, bKlammer) + vbCr + vbCr
            strAusgZwei = strAusgZwei + "Normale Feature:" + vbCr
            ReDim strErstellt(0)
        End If
        
#If cDebug Then
        Debug.Print swFeat.DateCreated
        Debug.Print swFeat.GetTypeName2
        Debug.Print "Feature " & swFeat.Name & " created by " & swFeat.CreatedBy
#End If
        Set swFeat = swFeat.GetNextFeature
    Loop
    
    strAusgZwei = strAusgZwei + Ausgabe(strErstellt, bKlammer)
    
#If cDebug Then
    Debug.Print strAusgZwei
    Debug.Print "----------------"
#Else
    If bKlammer Then
        strAusgZwei = strAusgZwei + vbCr + vbCr
        strAusgZwei = strAusgZwei + "Achtung!" + vbCr
        strAusgZwei = strAusgZwei + "Wenn in alten Dateien das Datum von heute steht, kann es sein, dass SolidWorks neue Feature hinzugefügt hat. "
        strAusgZwei = strAusgZwei + "Feature die es in der alten Version noch nicht gab. Die Daten sind markiert."
    End If

    If Len(strAusgEins + strAusgZwei) > 1023 Then
        strAusgEins = strAusgEins + vbCr + "Weitere Hinweise anzeigen?"
    
        If MsgBox(strAusgEins, vbYesNo Or vbInformation, "Versionshinweise Seite Eins") = vbYes Then
            MsgBox strAusgZwei, vbOKOnly Or vbInformation, "Versionshinweise Seite Zwei"
        End If
    Else
        MsgBox strAusgEins + strAusgZwei, vbOKOnly Or vbInformation, "Versionshinweise"
    End If
#End If

End Sub

Function IsDieserPC(strEingang As String) As String
    If Environ("username") = strEingang Then
        IsDieserPC = cAktPC
    Else
        IsDieserPC = strEingang
    End If
End Function


Function DatumIsHeute(strEingang As String, Optional bAM As Boolean) As String
    If strEingang <> "" Then
        Dim strDatum As String
        Dim strZeit As String
        
        strDatum = Left(strEingang, InStr(strEingang, " ") - 1)
        strZeit = Mid(strEingang, InStr(strEingang, " ") + 1)
        
        If strDatum = Date Then
            strDatum = cHeute
        ElseIf bAM Then
            strDatum = "am " + strDatum
        End If
        DatumIsHeute = strDatum + " " + strZeit
    End If
End Function

Function Ausgabe(strEingabe() As String, bKlammer As Boolean) As String
    Dim strBenutzer As String
    Dim strDatum As String
    Dim i As Integer
    Dim j As Integer
    
    For i = 0 To UBound(strEingabe)
        If strEingabe(i) <> "" Then
            strBenutzer = IsDieserPC(Left(strEingabe(i), InStr(strEingabe(i), cTrenner) - 1))
            strDatum = DatumIsHeute(Mid(strEingabe(i), InStr(strEingabe(i), cTrenner) + Len(cTrenner)), True)
            
            If InStr(strBenutzer, cAktPC) > 0 And InStr(strDatum, cHeute) > 0 Then
                strBenutzer = cKlammerAuf + strBenutzer
                strDatum = strDatum + cKlammerZu
                bKlammer = True
            End If
            
            If strBenutzer <> "" Then
                For j = 0 To cLaengeBenutzer - Len(strBenutzer)
                    strBenutzer = strBenutzer + "  "
                Next
                Ausgabe = Ausgabe + strBenutzer + strDatum

                If i < UBound(strEingabe) Then
                    Ausgabe = Ausgabe + "," + vbCr
                End If
            End If
        End If
    Next
End Function

Function ConvertDatum(strEingang As String) As String
    Dim iJahr As Integer
    Dim iTag As Integer
    
    iJahr = CInt(Left(strEingang, InStr(strEingang, "/") - 1))
    iTag = CInt(Mid(strEingang, InStr(strEingang, "/") + 1))
    
    If SchaltJahr(iJahr) Then
'Schaltjahr
        If iTag < 61 Then
            ConvertDatum = CStr(Day(iTag)) + "." + CStr(Month(iTag)) + "." + CStr(iJahr)
        ElseIf iTag = 61 Then
            ConvertDatum = "29.2." + CStr(iJahr)
        Else
            ConvertDatum = CStr(Day(iTag - 1)) + "." + CStr(Month(iTag - 1)) + "." + CStr(iJahr)
        End If
    Else
'kein Schaljahr
        ConvertDatum = CStr(Day(iTag)) + "." + CStr(Month(iTag)) + "." + CStr(iJahr)
    End If
End Function

Function ConvertFileVersionToSwMajorVersion(iVersNumber As Integer) As String
    Dim StrSwVers As String
    
    If iVersNumber >= 5000 Then
        StrSwVers = 2012 + (iVersNumber - 5000) / 1000
    Else
        Select Case iVersNumber
            Case 44
                StrSwVers = 95
            Case 243
                StrSwVers = 96
            Case 483
                StrSwVers = 97
            Case 629
                StrSwVers = "97Plus"
            Case 822
                StrSwVers = 98
            Case 1008
                StrSwVers = "98Plus"
            Case 1137
                StrSwVers = 99
            Case 1500
                StrSwVers = 2000
            Case 1750
                StrSwVers = 2001
            Case 1950
                StrSwVers = "2001Plus"
            Case 2200
                StrSwVers = 2003
            Case 2500
                StrSwVers = 2004
            Case 2800
                StrSwVers = 2005
            Case 3100
                StrSwVers = 2006
            Case 3400
                StrSwVers = 2007
            Case 3800
                StrSwVers = 2008
            Case 4100
                StrSwVers = 2009
            Case 4400
                StrSwVers = 2010
            Case 4700
                StrSwVers = 2011
        End Select
    End If
    
    ConvertFileVersionToSwMajorVersion = "SWX " & StrSwVers
End Function

Function SchaltJahr(iJahr As Integer) As Boolean
    'SchaltJahr = Day(DateSerial(iJahr, 2, 29)) = 29
    If (iJahr Mod 4 = 0 And iJahr Mod 100 <> 0) Or (iJahr Mod 400 = 0) Then SchaltJahr = True
End Function