'Excel-VBA/variabele selectie PDF maker' toevoegen
This commit is contained in:
parent
885ee78b65
commit
303ee5e0e7
1 changed files with 148 additions and 0 deletions
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