Private Sub cmdMergeXLbttn_Click()
'On Error GoTo Error_Handler
'Declare a variable named MySheetPath as string
Dim MySheetPath As String
Dim strFileNamePath As String
Dim strLink As String
'set file path to actual sheet
MySheetPath = "O:\Access\ProjectSheet.xlsx"
'Set up object variables to refer to Excel and Objects
Dim XL As Excel.Application
Dim XLBook As Excel.Workbook
Dim XLSheet As Excel.Worksheet
Dim strServiceAddress As String
Dim ctl As Control
Dim varItem As Variant
Dim BillingAddress As String
Dim AddyLineVar As String
Dim CompanyAddress As String
Dim SalutationVar As String
Dim CustCompany As String
Dim CustEmail As String
Dim EmailCC As String
Dim CustCell As String
'Open an instance of Excel, open the workbook.
Set XL = CreateObject("Excel.Application")
Set XLBook = XL.Workbooks.Open(MySheetPath)
Set XLSheet = XLBook.Worksheets(1)
'Make sure everything is visible
XL.Visible = True
XLBook.Application.Workbooks(1).Activate
XLBook.Windows(1).Visible = True
'Define top sheet in Workbook as XLSheet
Set XLSheet = XLBook.Worksheets(1)
'Set Company Address
CompanyAddress = [Company] & vbCrLf & ([sfrmContacts].[Form]![MailingAddress]) & vbCrLf & ([sfrmContacts].[Form]![City]) & ", " & ([sfrmContacts].[Form]![State]) & " " & ([sfrmContacts].[Form]![ZipCode])
'Start building AddyLineVar, by dealing with blank last name fields.
If IsNull([sfrmContacts].[Form]![Last]) Then
AddyLineVar = [Company]
'Just set salutation to generic.
SalutationVar = "Sir or Madam"
Else
AddyLineVar = ([sfrmContacts].[Form]![Title]) & " " & ([sfrmContacts].[Form]![First]) & " " & ([sfrmContacts].[Form]![Last])
'Add Company on after name.
If Not IsNull([Company]) Then
AddyLineVar = AddyLineVar & vbCrLf & [Company]
End If
'Salutation will be customer's last name
SalutationVar = ([sfrmContacts].[Form]![Title]) & " " & ([sfrmContacts].[Form]![Last]) & ", "
End If
'Add line break and Address lines.
AddyLineVar = AddyLineVar & vbCrLf & ([sfrmContacts].[Form]![MailingAddress])
'Tack on line break then city, state, and zip.
AddyLineVar = AddyLineVar & vbCrLf & ([sfrmContacts].[Form]![City]) & ", "
AddyLineVar = AddyLineVar & ([sfrmContacts].[Form]![State]) & " " & ([sfrmContacts].[Form]![ZipCode])
CustCompany = ([sfrmContacts].[Form]![Title]) & " " & ([sfrmContacts].[Form]![First]) & " " & ([sfrmContacts].[Form]![Last]) & vbCrLf & [Company]
'Start building BillingAddress
If IsNull([Billing Information].Form![BillToCompany]) Then
BillingAddress = AddyLineVar
Else
BillingAddress = ([Billing Information].Form![BillToCompany])
If Not IsNull([Billing Information].Form![BillCareOf]) Then
BillingAddress = BillingAddress & vbCrLf & "c/o " & ([Billing Information].Form![BillCareOf])
End If
If Not IsNull([Billing Information].Form![BillBoxNumber]) Then
BillingAddress = BillingAddress & vbCrLf & ([Billing Information].Form![BillBoxNumber])
End If
If Not IsNull([Billing Information].Form![BillAttn]) Then
BillingAddress = BillingAddress & vbCrLf & "Attn: " & ([Billing Information].Form![BillAttn])
End If
'Add line break and Address lines.
BillingAddress = BillingAddress & vbCrLf & ([Billing Information].Form![BillAddress])
'Tack on line break then city, state, and zip.
BillingAddress = BillingAddress & vbCrLf & ([Billing Information].Form![BillCity]) & ", "
BillingAddress = BillingAddress & ([Billing Information].Form![State]) & " " & ([Billing Information].Form![BillingZip])
End If
'Build CustEmail
If IsNull([Billing Information].Form![BillEmailTo]) Then
CustEmail = Nz([sfrmContacts].[Form]![E-mail address], "None Listed")
Else: CustEmail = ([Billing Information].Form![BillEmailTo])
End If
'Build EmailCC
If IsNull([Billing Information].Form![BillEmailToCC]) Then
EmailCC = "None Requested"
Else: EmailCC = ([Billing Information].Form![BillEmailToCC])
End If
' String Customer Cell Phone
If Not IsNull([sfrmCellPhone].Form![Mobile Phone]) Then
CustCell = [sfrmCellPhone].Form![Mobile Phone]
Else: CustCell = ""
End If
'Make Tax_Exempt field useful information
If TaxExempt = -1 Then
TaxExempttxt = "Yes"
Else: TaxExempttxt = ""
End If
XLSheet.Range("DateGen") = [sfrmJobInformation].[Form]![DateAdded]
XLSheet.Range("ProjectNumber") = "'" & JobNumber & ([sfrmPMTitles].[Form]![JobExtension])
XLSheet.Range("CompanyAdd") = CompanyAddress
XLSheet.Range("Contact") = ([sfrmContacts].[Form]![First]) & " " & ([sfrmContacts].[Form]![Last])
XLSheet.Range("Phone") = ([sfrmContacts].[Form]![Phone])
XLSheet.Range("Fax") = ([sfrmContacts].[Form]![BusinessFax])
XLSheet.Range("ProjectDescription") = ProjectDescription
XLSheet.Range("ServiceAdd") = Me!ServiceAddress.Value 'returned only first selection when combo box is used, text box transfers whole string
XLSheet.Range("City") = City
XLSheet.Range("State") = State
XLSheet.Range("ProjectType") = ([sfrmProjectType].[Form]![ProjectType])
XLSheet.Range("PurchaseOrder") = PONumber
XLSheet.Range("OnsiteContact") = [OnsiteContact]
XLSheet.Range("BillTo") = BillingAddress
XLSheet.Range("CellPhone") = CustCell
XLSheet.Range("CustEmail") = CustEmail
XLSheet.Range("EmailCC") = EmailCC
XLSheet.Range("PM") = [Manager]
XLSheet.Range("ExemptStatus") = TaxExempttxt
'XLSheet.Range("Hazards") = AHA
'With Range("Hazards")
'.Font.Italic = True
'.Value = "Hazards" & "Controls"
'End With
'set file path
strLink = Replace(Link, "#", "")
strFileNamePath = (strLink & "\" & [JobNumber] & " " & "ProjectSheet" & ".xlsx")
'check if file exists and save to network location
If Dir(strFileNamePath, vbDirectory) = "" Then
ActiveWorkbook.SaveAs strFileNamePath
MsgBox "Your project sheet is ready and has been saved.", vbOKOnly, "Successful"
Else
MsgBox "Your project sheet is ready but this may be a duplicate. You must manually save this file.", vbExclamation
End If
Exit_Procedure:
Exit Sub
Error_Handler:
MsgBox "An error has occurred in this application." & " Please contact your technical support with the following information:" & vbCrLf & vbCrLf & "Error Number" & " " & Err.Number & ", " & Err.Description, Buttons:=vbCritical
Resume Exit_Procedure
End Sub