From 303ee5e0e7bbe48dfaa1309770a935b9a5996066 Mon Sep 17 00:00:00 2001
From: Mathijs Lermer <mathijs@lermer.nl>
Date: Wed, 3 Mar 2021 13:57:34 +0100
Subject: [PATCH] 'Excel-VBA/variabele selectie PDF maker' toevoegen

---
 Excel-VBA/variabele selectie PDF maker | 148 +++++++++++++++++++++++++
 1 file changed, 148 insertions(+)
 create mode 100644 Excel-VBA/variabele selectie PDF maker

diff --git a/Excel-VBA/variabele selectie PDF maker b/Excel-VBA/variabele selectie PDF maker
new file mode 100644
index 0000000..7abbb0e
--- /dev/null
+++ b/Excel-VBA/variabele selectie PDF maker	
@@ -0,0 +1,148 @@
+Sub MRL_Selectie()
+'voorbeelden:
+'https://www.wallstreetmojo.com/vba-variable-range/
+
+'variabelen maken
+    
+  'voor de teller
+    Dim vCount As Variant 'De view couter
+    Dim xScreen As Boolean
+    Dim I As Long
+
+'Start
+LInput:
+    vCount = Sheets("Printen").Range("c8").Value
+    If TypeName(vCount) = "Boolean" Then Exit Sub
+    
+ 'Controle op fouten
+    If (vCount = "") Or (Not IsNumeric(vCount)) Or (vCount < 1) Then
+        MsgBox "Ergens gaat iets fout, neem contact op met Mathijs", vbInformation, "Oeps"
+        GoTo LInput
+    Else
+    
+    'Werkblad berekenen
+    Application.Calculate
+    
+     
+        xScreen = Application.ScreenUpdating
+        Application.ScreenUpdating = False
+        For I = Sheets("Printen").Range("c7").Value To vCount
+            Sheets("Printen").Range("c6").Value = I
+
+    Call MRL_PDF_MAKER
+            'ActiveSheet.PrintOut
+        Next
+        'ActiveSheet.Range("c6").ClearContents
+        Application.ScreenUpdating = xScreen
+    End If
+Worksheets("Printen").Activate
+End Sub
+
+Sub MRL_PDF_MAKER()
+    Dim sh As Worksheet
+    Dim FileName As String
+    
+    Dim printview As Range
+    Dim vanx As Integer
+    Dim vany As Integer
+    Dim totx As Integer
+    Dim toty As Integer
+    Dim rngx As Integer
+    Dim rngy As Integer
+
+    If ActiveWindow.SelectedSheets.Count > 1 Then
+        MsgBox "There is more then one sheet selected," & vbNewLine & _
+               "ungroup the sheets and try the macro again"
+    Else
+    
+
+'Werkblad berekenen
+    Application.Calculate
+    
+'variabelen waarden geven
+    vanx = Sheets("Printen").Range("d2").Value
+    vany = Sheets("Printen").Range("e2").Value
+    totx = Sheets("Printen").Range("d3").Value
+    toty = Sheets("Printen").Range("e3").Value
+    
+'waarde controleren
+    'NTB
+    
+'berekenenvam:
+    'tussenwaarde's
+        rngx = totx - vanx + 1
+        rngy = toty - vany + 1
+    Worksheets("Planning").Activate
+    'de printview rng instellen
+        Set printview = Cells(vany, vanx).Resize(rngy, rngx)
+    
+'de printview selecteren
+
+    printview.Select
+    
+    
+    
+        'Call the function with the correct arguments
+        'For a fixed range use this line
+        FileName = MRL_Create_PDF(Source:=Selection, _
+                                  FixedFilePathName:=Sheets("Printen").Range("C9").Value _
+                                                    & Sheets("Printen").Range("C10").Value _
+                                                    & Sheets("Printen").Range("C11").Value & ".pdf", _
+                              OverwriteIfFileExist:=True, _
+                              OpenPDFAfterPublish:=True)
+        'For the selection use Selection in the Source argument
+        'FileName = MRL_Create_PDF(Source:=Selection)
+
+        'For a fixed file name use this in the FixedFilePathName argument
+        'FixedFilePathName:="C:\Users\Ron\Test\YourPdfFile.pdf"
+
+        If FileName <> "" Then
+            'Ok, you find the PDF where you saved it
+            'You can call the mail macro here if you want
+        Else
+            MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
+                   "Microsoft Add-in is not installed" & vbNewLine & _
+                   "You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
+                   "The path to Save the file in arg 2 is not correct" & vbNewLine & _
+                   "You didn't want to overwrite the existing PDF if it exist"
+        End If
+    End If
+End Sub
+
+Function MRL_Create_PDF(Source As Object, FixedFilePathName As String, _
+                        OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
+    Dim FileFormatstr As String
+    Dim Fname As Variant
+
+        If FixedFilePathName = "" Then
+            'Open the GetSaveAsFilename dialog to enter a file name for the pdf
+            FileFormatstr = "PDF Files (*.pdf), *.pdf"
+            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
+                                                  Title:="Create PDF")
+
+            'If you cancel this dialog Exit the function
+            If Fname = False Then Exit Function
+        Else
+            Fname = FixedFilePathName
+        End If
+
+        'If OverwriteIfFileExist = False we test if the PDF
+        'already exist in the folder and Exit the function if that is True
+        If OverwriteIfFileExist = False Then
+            If Dir(Fname) <> "" Then Exit Function
+        End If
+
+        'Now the file name is correct we Publish to PDF
+        On Error Resume Next
+        Source.ExportAsFixedFormat _
+                Type:=xlTypePDF, _
+                FileName:=Fname, _
+                Quality:=xlQualityStandard, _
+                IncludeDocProperties:=True, _
+                IgnorePrintAreas:=False, _
+                OpenAfterPublish:=OpenPDFAfterPublish
+        On Error GoTo 0
+
+        'If Publish is Ok the function will return the file name
+        If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
+End Function
\ No newline at end of file