Microsoft Access - Salvare report in pdf suddivisi

Asked By Alessia on 30-May-12 12:59 AM
Ho un db abbastanza grande, con numerose tabelle collegate e query.
Da una query lancio un report di circa 3000pagine che poi converto in pdf e da pdf converter suddivido in base al
campo operatore, salvo in una cartella ed invio via mail all'interessato.

Vorrei creare una routine con visual basic che faccia tutto da sola, cioè:
Lanciare la query, dividere il report in base al codice operatore, creare il pdf e salvarlo in una cartella specifica.

Il nome dei pdf creati dovrebbe essere:
Operatore-mese-Report

In cui Operatore lo pesca dal campo operatore, mese lo pesca dalla colonna mese e Report resta sempre fisso.
 
Ho qualche minima conoscenza di visual basic (nel mio db l'ho usato nelle mask) e capisco abbastanza sql.

Il mio problema è che il db l'ho creato nel 2009 e mi sono molto arrugginita quindi non so da dove cominciare.

Grazie
Somesh Yadav replied to Alessia on 30-May-12 02:38 AM
try this,
http://www.vbaexpress.com/kb/getarticle.php?kb_id=789
wally eye replied to Alessia on 30-May-12 06:02 PM
I think you would need to run each Operator's report by itself, then save each resulting to the separate PDF's.  This would be much simpler than trying to split a report.
Pat Hartman replied to Alessia on 02-Jun-12 10:48 AM
Private Sub cmdSendEmails_Click()
  Dim strValue As String
  Dim db As DAO.Database
  Dim rs As DAO.Recordset
  Dim rs2 As DAO.Recordset
  Dim qd As DAO.QueryDef
  Dim td As DAO.TableDef
  Dim strMsg As String
  Dim StartTime As Date
  Dim EndTime As Date
  Dim stDocName As String
  Dim QUOTE As String
  Dim DocName As String
  Dim strPath As Variant
  Dim strSQL As String
  Dim CountErr As Integer
  Dim TestEmail As Boolean
  Dim strEmail As String
   
On Error GoTo ErrProc
 
  QUOTE = """"
  CountErr = 0
  Set db = CurrentDb()
  stDocName = "Inspectors report"
  TestEmail = DLookup("TestEmail", "tblEmail", "RecID = 1")
   
  'get path
  strPath = DLookup("FileFolder", "tblEMail", "RecID = 1")
  If strPath & "" = "" Then
    MsgBox "Please open email defaults form and add document path.", vbOKOnly
    Exit Sub
  End If
  If Right(strPath, 1) <> "\" Then
    strPath = strPath & "\"
  End If
 
  'delete old email errors
  strSQL = "Delete * From tblNoEmailAddress"
  DoCmd.SetWarnings False
  DoCmd.Hourglass True
  DoCmd.RunSQL strSQL
  DoCmd.SetWarnings True
  DoCmd.Hourglass False
   
  'open email error recordset.
  Set td = db.TableDefs!tblNoEmailAddress
  Set rs2 = td.OpenRecordset
   
   
  Set qd = db.QueryDefs!qGetIRDataJobs
  Set rs = qd.OpenRecordset
   
  StartTime = Now()
  Me.lblElapsedTime.Visible = False
  Me.lblStatus.Visible = True
  Me.lblStatus.Caption = "Sending Emails...."
  Me.Recalc
  DoEvents
  DoCmd.Hourglass (True)
   
  If Me.txtJob & "" = "" Then
    Do Until rs.EOF = True
      Me.txtJob = rs!Job
      GoSub PrintOrEmail
      rs.MoveNext
    Loop
  Else
    GoSub PrintOrEmail
  End If
   
  DoCmd.Hourglass (False)
  DoCmd.SetWarnings (True)
  Me.lblStatus.Caption = "Complete"
  EndTime = Now()
  Me.lblStatus.Visible = True
  Me.lblElapsedTime.Visible = True
  Me.lblElapsedTime.Caption = DateDiff("n", StartTime, EndTime) & " Minutes"
   
  'close recordsets
  rs.Close
  rs2.Close
  If CountErr > 0 Then
    DoCmd.OpenReport "rptNoEmailAddress", acViewPreview
  Else
    MsgBox "All reports were emailed.", vbOKOnly
  End If
ExitProc:
  Exit Sub
   
PrintOrEmail:
  DocName = strPath & rs!Job & "_" & Format(Date, "yyyymmdd") & ".pdf"
  If rs!IR_Email & "" = "" Then
    DoCmd.OpenReport stDocName, acViewNormal
    rs2.AddNew
      rs2!Job = Me.txtJob
      rs2!PrintDate = Now()
    rs2.Update
    CountErr = CountErr + 1
  Else
    DoCmd.OutputTo acOutputReport, stDocName, acFormatPDF, DocName, False
    ' send the PDF via outlook
    If TestEmail = True Then
      strEmail = "dddd@sssssss.net"
    Else
      strEmail = rs!IR_Email
    End If
     
    strValue = Email_Via_Outlook(strEmail, "Quantity Review Report", "", False, DocName)
  End If
  Return
ErrProc:
  MsgBox Err.Number & "--" & Err.Description
  Resume ExitProc
   
End Sub
Pat Hartman replied to Alessia on 02-Jun-12 10:52 AM
OOPs.  Forgot the email code;
Function Email_Via_Outlook(vAddress, vSubject, vBody, DisplayMsg As Boolean, Optional strFileName)
  'http://www.access-programmers.co.uk/forums/showthread.php?t=214158
Dim oOL As Outlook.Application
Dim oMailItem As Outlook.MailItem
Dim oRecip As Outlook.Recipient
Dim oAttach As Outlook.Attachment
Dim db As DAO.Database
Dim td As DAO.TableDef
Dim rs As DAO.Recordset
Dim AttPath As String
On Error GoTo ErrProc
  Set db = CurrentDb()
  Set td = db.TableDefs!tblEmail
  Set rs = td.OpenRecordset
  AttPath = strFileName
' Create the Outlook session.
Set oOL = CreateObject("Outlook.Application")
' Create the message.
Set oMailItem = oOL.CreateItem(olMailItem)
 
  ' Add the To recipient(s) to the message.
  Set oRecip = oMailItem.Recipients.Add(vAddress)
  oRecip.Type = olTo
  oMailItem.Subject = vSubject
  oMailItem.body = vBody
'    oMailItem.SendUsingAccount = rs!eMailOnBehalfOf
  
  ' Add attachments to the message.
  If Not IsMissing(AttPath) And AttPath <> "" Then
    Set oAttach = oMailItem.Attachments.Add(AttPath)
  End If
  
  ' Resolve each Recipient's name.
  For Each oRecip In oMailItem.Recipients
    oRecip.Resolve
  Next
  ' Should we display the message before sending?
  If DisplayMsg Then
    oMailItem.Display
  Else
    oMailItem.Save
    oMailItem.Send
  End If
 
Set oOL = Nothing
ExitProc:
  Exit Function
 
ErrProc:
  Select Case Err.Number
    Case Else
      MsgBox Err.Number & "--" & Err.Description
  End Select
  
End Function