'Excel-VBA/variabele selectie PDF maker' toevoegen
This commit is contained in:
parent
885ee78b65
commit
303ee5e0e7
148
Excel-VBA/variabele selectie PDF maker
Normal file
148
Excel-VBA/variabele selectie PDF maker
Normal file
|
|
@ -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
|
||||
Loading…
Reference in a new issue