I would like to make exports based on the boxes I checked
therefore with a lot of help I build the following code
Private Sub CommandButton1_Click()
Dim xSht As Worksheet, xFileDlg As FileDialog, xFolder As String, xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object, xEmailObj As Object, xUsedRng As Range, xArrShetts As Variant
Dim xPDFNameAddress As String, xStr As String, rngExp As Range, lastRng As Range
xArrShetts = sheetsArr(Me) 'do not forget the keep the sheetsArr function...
For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
Set lastRng = xSht.Range("A" & xSht.Rows.Count).End(xlUp) 'determine the last cell in A:A
Set rngExp = xSht.Range(lastRng.Offset(-26), lastRng.Offset(, 7)) 'create the range to be exported as pdf
With xSht.PageSetup
.PaperSize = xlPaperA4
.PrintArea = rngExp.Address(0, 0)
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
rngExp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard, IgnorePrintAreas:=False 'export the range, not the sheet
End If
xArrShetts(I) = xStr
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.cc = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
Next
If .DisplayEmail = False Then
'.Send
End If
End With
End Sub
Private Function sheetsArr(uF As UserForm) As Variant
Dim c As MSForms.Control, strCBX As String, arrSh
For Each c In uF.Controls
If TypeOf c Is MSForms.CheckBox Then
If c.Value = True Then strCBX = strCBX & "," & c.Caption
End If
Next
sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function
Private Sub CommandButton2_Click()
Unload basicUserform
End Sub
the problem is when I run the code no attachments show up or can be found in the destination map I choose earlier.
I also put the file here so you can see for yourself.: https://easyupload.io/ufnmvr
I appreciate your help and time!
Aucun commentaire:
Enregistrer un commentaire