Image-Handler, Technical Reporting and Sourcefile exports

Started to implement image handling for technical reports. Not sure if heading in the right direction. Added page 2 for technical reports. Export VBA code to sourcefiles for better git handling
2024-07-19 02:01:29 +02:00
parent 95e870553e
commit df618ca588
12 changed files with 547 additions and 2 deletions
--- a/cockpit.xlsm
+++ b/cockpit.xlsm
--- a/src/BaseModule.bas
+++ b/src/BaseModule.bas
@@ -0,0 +1,85 @@
+Attribute VB_Name = "BaseModule"
+Option Explicit
+'
+' Base-Code for Magic Cockpit
+'
+' @copyright 2024 Siegrist & Tschuor AG
+' @author Marco Gr<47>tsch <marco.graetsch@siegrist-tschour.ch>
+'
+Public Const PWD As String = "paddyhat"
+Public Const SECTION_IMAGE As String = "Image"
+Public Const SECTION_DOCUMENT As String = "Document"
+Public Const SHEET_CONFIG As String = "Konfiguration"
+Public Const SHEET_ROOTDATA As String = "Auftragsdaten"
+
+' Save a document as PDF
+Sub SaveDocument(sourceName As String, section As String, Optional childPath As String)
+    Dim fullPath As String
+    Dim projectDir As String
+    
+    projectDir = projectPath(section, childPath)
+    fullPath = projectDir & "\" & sourceName
+    
+    ActiveWorkbook.Save
+    With Sheets(sourceName)
+        .Select
+        .ExportAsFixedFormat Type:=xlTypePDF, _
+            Filename:=fullPath & ".pdf", _
+            Quality:=xlQualityStandard
+    End With
+End Sub
+
+' Generate the current project path
+Public Function projectPath(section As String, Optional childPath As String) As String
+    Dim rootPath As String
+    Dim projectName As String
+    Dim typePath As String
+    
+    With Sheets(SHEET_CONFIG)
+        rootPath = .Range("B2").Value
+        projectName = .Range("B3").Value
+        If section = SECTION_IMAGE Then
+            typePath = .Range("B4").Value
+        ElseIf section = SECTION_DOCUMENT Then
+            typePath = .Range("B5").Value
+        Else
+            typePath = ""
+        End If
+    End With
+    
+    If childPath <> "" And typePath <> "" Then
+        typePath = typePath & "\" & childPath
+    End If
+    
+    projectPath = rootPath & "\" & projectName & "\" & typePath
+End Function
+
+' Create a subdirectory
+Private Sub CreateDir(strPath As String)
+    Dim el As Variant
+    Dim strCheckPath As String
+
+    strCheckPath = ""
+    For Each el In Split(strPath, "\")
+        strCheckPath = strCheckPath & el & "\"
+        If Len(Dir(strCheckPath, vbDirectory)) = 0 Then MkDir strCheckPath
+    Next
+End Sub
+
+' Initialize the project folder
+Private Sub InitProjectDir()
+    CreateDir (projectPath(SECTION_IMAGE))
+    CreateDir (projectPath(SECTION_DOCUMENT))
+End Sub
+
+' Initialize the project folder handler
+Sub InitProject_click()
+    Dim yesno As Integer
+    yesno = MsgBox("Der Projektordner wird initialisiert. Sind sie sicher?", _
+        vbQuestion + vbYesNo + vbDefaultButton2, "Cockpit initialisieren")
+    If yesno = vbYes Then
+        InitProjectDir
+        ActiveWorkbook.Save
+        MsgBox ("Der Projektordner wurde erfolgreich initialisiert.")
+    End If
+End Sub
--- a/src/DieseArbeitsmappe.cls
+++ b/src/DieseArbeitsmappe.cls
@@ -0,0 +1,33 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "DieseArbeitsmappe"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True
+Option Explicit
+'
+' Workbook event-handler for Magic Cockpit
+'
+' @copyright 2024 Siegrist & Tschuor AG
+' @author Marco Gr<47>tsch <marco.graetsch@siegrist-tschour.ch>
+'
+Private Sub Workbook_Open()
+    Dim fileFolder As String
+    Dim projectName As String
+    Dim rootFolder As String
+    
+    fileFolder = ThisWorkbook.Path
+    projectName = Right(fileFolder, Len(fileFolder) - InStrRev(fileFolder, "\"))
+    rootFolder = Left(fileFolder, Len(fileFolder) - Len(projectName))
+    
+    With Sheets(SHEET_CONFIG)
+        .Unprotect PWD
+        .Range("B3").Value = projectName
+        .Range("B2").Value = rootFolder
+        .Protect PWD
+    End With
+End Sub
+
--- a/src/ImageHandler.bas
+++ b/src/ImageHandler.bas
@@ -0,0 +1,100 @@
+Attribute VB_Name = "ImageHandler"
+Option Explicit
+'
+' Image Handler-for Magic Cockpit
+'
+' @copyright 2024 Siegrist & Tschuor AG
+' @author Marco Gr<47>tsch <marco.graetsch@siegrist-tschour.ch>
+'
+Public Const SCALE_FACTOR As Double = 0.5
+
+Sub InsertImage_click()
+    InsertImage _
+        target:=ActiveCell.MergeArea, _
+        Sheet:=ActiveSheet, _
+        FitCell:=True, _
+        Padding:=5
+End Sub
+
+Private Sub InsertImage( _
+        target As Range, _
+        Sheet As Worksheet, _
+        Optional Width As Double = 0, _
+        Optional Padding As Integer = 0, _
+        Optional ForceWidth As Boolean = False, _
+        Optional FitCell As Boolean = True _
+    )
+    
+    With Application.FileDialog(msoFileDialogFilePicker)
+        .AllowMultiSelect = False
+        .ButtonName = "Bild einf<6E>gen"
+        .Title = "Bild ausw<73>hlen"
+        .Filters.Clear
+        .Filters.Add "Alle Bilddateien", "*.jpg;*.jpeg;*.png;*.webp;*.svg;*.tiff"
+        .Filters.Add "Bitmap-Dateien", "*.jpg;*.jpeg;*.png;*.webp"
+        .Filters.Add "Vektor-Grafiken", "*.svg;*.tiff"
+
+        If .Show = -1 Then
+            Dim source As String
+            source = .SelectedItems(1)
+            
+            Dim img As Object
+            Set img = Sheet.Pictures.Insert(source)
+        
+            With img
+                'Scale image size
+                .ShapeRange.ScaleWidth SCALE_FACTOR, msoFalse, msoScaleFromTopLeft
+                .ShapeRange.ScaleHeight SCALE_FACTOR, msoFalse, msoScaleFromTopLeft
+            
+                If FitCell = True Then
+                    .Placement = xlMoveAndSize
+                    .Width = calcWidth(target.Width, Padding)
+                Else
+                'Set image sizes in points (72 point per inch)
+                    If ForceWidth <> True Then
+                        If .Width >= .Height Then
+                            'Landscape
+                            .Height = cm2pt(Width)
+                        Else
+                            'Portrait
+                            .Width = cm2pt(Width)
+                        End If
+                    Else
+                        .Width = cm2pt(Width)
+                    End If
+                End If
+                
+                'Position Image
+                .Left = calcLeft(target.Left, Padding)
+                .Top = calcTop(target.Top, Padding)
+            End With
+            target.Columns(6).Select
+        End If
+    End With
+End Sub
+
+Private Function calcWidth(CellWidth As Integer, Padding As Integer)
+    calcWidth = CellWidth - (Padding * 2)
+End Function
+
+Private Function calcTop(Top As Integer, Padding As Integer)
+    calcTop = Top + Padding
+End Function
+
+Private Function calcLeft(Left As Integer, Padding As Integer)
+    calcLeft = Left + Padding
+End Function
+
+Private Function cm2pt(Length As Double)
+    Dim factor As Double
+    factor = 72 / 2.54
+    
+    cm2pt = Length * factor
+End Function
+
+Private Function pt2cm(Length As Integer)
+    Dim factor As Double
+    factor = 2.54 / 72
+    
+    pt2cm = Length * factor
+End Function
--- a/src/LayoutHandler.bas
+++ b/src/LayoutHandler.bas
@@ -0,0 +1,33 @@
+Attribute VB_Name = "LayoutHandler"
+Option Explicit
+
+Sub InsertImageRow_click()
+    InsertImageRow source:=Range("A131:J133")
+End Sub
+
+Private Sub InsertImageRow(source As Range)
+    Dim currentRow As Integer
+    Dim nextRow As Integer
+    Dim imageNumber As Variant
+    
+    currentRow = source.Row
+    nextRow = currentRow + 3
+    
+    Application.ScreenUpdating = False
+    source.Copy Destination:=Range("A" & CStr(nextRow))
+    imageNumber = Range("B" & CStr(currentRow)).Value
+    Range("B" & CStr(nextRow)).Value = imageNumber + 1
+    With Range("A" & CStr(nextRow + 1))
+        .Select
+        .RowHeight = Range("A" & CStr(currentRow + 1)).RowHeight
+    End With
+    With Range("A" + CStr(nextRow + 2))
+        .RowHeight = Range("A" & CStr(currentRow + 2)).RowHeight
+    End With
+    Application.ScreenUpdating = True
+End Sub
+
+Private Sub InsertPageBreak()
+    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
+End Sub
+
--- a/src/RootdataPage.bas
+++ b/src/RootdataPage.bas
@@ -0,0 +1,228 @@
+Attribute VB_Name = "RootdataPage"
+Option Explicit
+'
+' Rootpage code for Magic Cockpit
+'
+' @copyright 2024 Siegrist & Tschuor AG
+' @author Marco Gr<47>tsch <marco.graetsch@siegrist-tschour.ch>
+'
+
+' Save the document as PDF handler
+Sub ExportRootpage_click()
+    SaveRootPage
+End Sub
+
+' Reset the whole document handler
+Sub ResetRootpage_click()
+    ResetRootPage
+End Sub
+
+' Set the order date to today handler
+Sub OrderDate_click()
+    With Sheets(SHEET_ROOTDATA)
+        .Range("C5").Value = Date
+    End With
+End Sub
+
+' Set the incident date to today handler
+Sub IncidentDate_click()
+    With Sheets(SHEET_ROOTDATA)
+        .Range("I5").Value = Date
+    End With
+End Sub
+
+' Set the incident date to yesterday handler
+Sub IncidentDateYesterday_click()
+    With Sheets(SHEET_ROOTDATA)
+        .Range("I5").Value = Date - 1
+    End With
+End Sub
+
+' Validate and save the root data page as PDF
+Private Sub SaveRootPage()
+    Application.ScreenUpdating = False
+    
+    Dim message As String
+    message = ValidateSheet()
+    If message <> "" Then
+        MsgBox (message)
+        GoTo endMakro
+    End If
+    
+    With Sheets(SHEET_ROOTDATA)
+        .Unprotect PWD
+        SaveDocument sourceName:=.name, section:=SECTION_DOCUMENT
+    End With
+    
+endMakro:
+    Sheets(SHEET_ROOTDATA).Protect PWD
+    Application.ScreenUpdating = True
+End Sub
+
+' Reset the root data page
+Private Sub ResetRootPage()
+    Dim yesno As Integer
+    yesno = MsgBox("Durch diese Aktion werden alle Daten gel<65>scht! Sind sie sicher?", _
+        vbExclamation + vbYesNo + vbDefaultButton2, _
+        "Auftragsdaten zur<75>cksetzen" _
+    )
+    
+    If yesno = vbYes Then
+        Application.ScreenUpdating = False
+        With Sheets(SHEET_ROOTDATA)
+            .Unprotect PWD
+            
+            ' Row 1
+            .Range("C5").MergeArea.ClearContents
+            .Range("C6").MergeArea.ClearContents
+            .Range("C7").MergeArea.ClearContents
+            .Range("C8").MergeArea.ClearContents
+            .Range("C9").MergeArea.ClearContents
+            .Range("I5").MergeArea.ClearContents
+            .Range("I6").MergeArea.ClearContents
+            .Range("I7").MergeArea.ClearContents
+            .Range("I8").MergeArea.ClearContents
+            .Range("I9").MergeArea.ClearContents
+            .Range("I10").MergeArea.ClearContents
+            .Range("I11").MergeArea.ClearContents
+            
+            ' Row 2
+            .Range("B14").MergeArea.ClearContents
+            .Range("B15").MergeArea.ClearContents
+            .Range("B16").MergeArea.ClearContents
+            .Range("B17:B19").ClearContents
+            .Range("C17").MergeArea.ClearContents
+            .Range("C18").MergeArea.ClearContents
+            .Range("C19").MergeArea.ClearContents
+            .Range("H14").MergeArea.ClearContents
+            .Range("H15").MergeArea.ClearContents
+            .Range("H16").MergeArea.ClearContents
+            .Range("H17:H19").ClearContents
+            .Range("I17").MergeArea.ClearContents
+            .Range("I18").MergeArea.ClearContents
+            .Range("I19").MergeArea.ClearContents
+            
+            ' Row 3
+            .Range("B22").MergeArea.ClearContents
+            .Range("B23").MergeArea.ClearContents
+            .Range("B24").MergeArea.ClearContents
+            .Range("B25:B27").ClearContents
+            .Range("C25").MergeArea.ClearContents
+            .Range("C26").MergeArea.ClearContents
+            .Range("C27").MergeArea.ClearContents
+            .Range("H22").MergeArea.ClearContents
+            .Range("H23").MergeArea.ClearContents
+            .Range("H24").MergeArea.ClearContents
+            .Range("H25:H27").ClearContents
+            .Range("I25").MergeArea.ClearContents
+            .Range("I26").MergeArea.ClearContents
+            .Range("I27").MergeArea.ClearContents
+            
+            ' Row 4
+            .Range("B30").MergeArea.ClearContents
+            .Range("B31").MergeArea.ClearContents
+            .Range("B32").MergeArea.ClearContents
+            .Range("B33").MergeArea.ClearContents
+            .Range("B34").MergeArea.ClearContents
+            .Range("B35:B36").ClearContents
+            .Range("H30").MergeArea.ClearContents
+            .Range("H31").MergeArea.ClearContents
+            .Range("H32").MergeArea.ClearContents
+            .Range("H33:H35").ClearContents
+            .Range("H36").MergeArea.ClearContents
+            .Range("I33").MergeArea.ClearContents
+            .Range("I34").MergeArea.ClearContents
+            .Range("I35").MergeArea.ClearContents
+            
+            ' Row 5
+            .Range("C39").MergeArea.ClearContents
+            
+            ' Row 6
+            .Range("A42").MergeArea.ClearContents
+            .Range("A43").MergeArea.ClearContents
+            .Range("A44").MergeArea.ClearContents
+            .Range("A45").MergeArea.ClearContents
+            .Range("A46").MergeArea.ClearContents
+            
+            .Range("C5").Select
+            .Protect PWD
+        End With
+        
+        ActiveWindow.ScrollRow = 1
+        ActiveWorkbook.Save
+        Application.ScreenUpdating = True
+    End If
+End Sub
+
+' Validate the data before saving the document
+Private Function ValidateSheet() As String
+    Dim errMsg As String
+    errMsg = ""
+    
+    With Sheets(SHEET_ROOTDATA)
+        If .Range("C5").Value = "" Then
+            errMsg = "Das Auftragsdatum muss angegeben werden!"
+            .Range("C5").Select
+            ActiveWindow.ScrollRow = 3
+            GoTo result
+        End If
+        If .Range("C6").Value = "" Then
+            errMsg = "Die Auftragsnummer muss angegeben werden!"
+            .Range("C6").Select
+            ActiveWindow.ScrollRow = 3
+            GoTo result
+        End If
+        If .Range("C7").Value = "" Then
+            errMsg = "Die Auftragsart muss angegeben werden!"
+            .Range("C7").Select
+            ActiveWindow.ScrollRow = 3
+            GoTo result
+        End If
+        If .Range("C8").Value = "" Then
+            errMsg = "Der Auftragsstatus muss angegeben werden!"
+            .Range("C8").Select
+            ActiveWindow.ScrollRow = 3
+            GoTo result
+        End If
+        If .Range("C9").Value = "" Then
+            errMsg = "Der Sachbearbeiter muss angegeben werden!"
+            .Range("C9").Select
+            ActiveWindow.ScrollRow = 3
+            GoTo result
+        End If
+        If .Range("B22").Value = "" Then
+            errMsg = "Der Name des Schadensobjekts muss angegeben werden!"
+            .Range("B22").Select
+            ActiveWindow.ScrollRow = 20
+            GoTo result
+        End If
+        If .Range("B23").Value = "" Then
+            errMsg = "Die Adresse des Schadensobjekts muss angegeben werden!"
+            .Range("B23").Select
+            ActiveWindow.ScrollRow = 20
+            GoTo result
+        End If
+        If .Range("B24").Value = "" Then
+            errMsg = "Die Adresse des Schadensobjekts muss angegeben werden!"
+            .Range("B24").Select
+            ActiveWindow.ScrollRow = 20
+            GoTo result
+        End If
+        If .Range("B25").Value = "" Then
+            errMsg = "Der Haustyp des Schadensobjekts muss angegeben werden!"
+            .Range("B25").Select
+            ActiveWindow.ScrollRow = 20
+            GoTo result
+        End If
+        If .Range("C31").Value = "" Then
+            errMsg = "Bitte den Schaden beschreiben!"
+            .Range("C31").Select
+            ActiveWindow.ScrollRow = 29
+            GoTo result
+        End If
+    End With
+    
+result:
+    ValidateSheet = errMsg
+End Function
+
--- a/src/Tabelle1.cls
+++ b/src/Tabelle1.cls
@@ -0,0 +1,11 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "Tabelle1"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True
+Option Explicit
+
--- a/src/Tabelle2.cls
+++ b/src/Tabelle2.cls
@@ -0,0 +1,11 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "Tabelle2"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True
+Option Explicit
+
--- a/src/Tabelle3.cls
+++ b/src/Tabelle3.cls
@@ -0,0 +1,11 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "Tabelle3"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True
+Option Explicit
+
--- a/src/Tabelle4.cls
+++ b/src/Tabelle4.cls
@@ -0,0 +1,11 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "Tabelle4"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True
+Option Explicit
+
--- a/src/Tabelle5.cls
+++ b/src/Tabelle5.cls
@@ -0,0 +1,11 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "Tabelle5"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True
+Option Explicit
+
--- a/src/Tabelle6.cls
+++ b/src/Tabelle6.cls
@@ -0,0 +1,11 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "Tabelle6"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True
+Option Explicit
+