MS-Office/Excel-VBA/variabele selectie PDF maker

148 lines
4.9 KiB
Text
Raw Permalink Normal View History

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