LinkBack URL
About LinkBacks
VBA Error '1004'- Userform use and emailing data
Hi all,
I'm a new excelForum user and have a VBA related question.
I've created a userform below and I have a code to help write the data entered in the form do the following:
1. Save the data in a worksheet (Asset History) within the same workbook,
2. Copy the newly entered data into a another worksheet (Asset Form).
3. Take an image of the data from worksheet (Asset Form) and
a) Create a HTML image on out look
b) Send out an email (Get the email distribution from worksheet (EmailList)
4. I also want to be able to select the data nad change if any of the information changes using the userform.
Not sure why my code is getting stuck and getting the attached error "1004" when I get to saving and emailing. My guess is that the error is on the Checklist option explicit but I cants fix. Please help.
Here is the full coding
Private Sub cmdsave_Click()
Dim cell As Range
Dim rowoffset As Integer
Dim ws As Worksheet
Dim rng As Range
Dim rFind As Range
Dim RowCount As Long
Dim ctl As Control
Dim NewID As Integer
If Not IsDate(Me.txtEntryDate.Value) Then
MsgBox "You must fill in the request date.", vbCritical, "Date Missing"
Me.txtEntryDate.SetFocus
End If
If Me.cboShopName.Value = "" Then
MsgBox "Please choose a Shop Name.", vbExclamation, "Missing Shop Name"
Me.cboShopName.SetFocus
End If
If Me.txtPartNo.Value = "" Then
MsgBox "You must enter a Part No.", vbCritical, "Part No. Required"
Me.txtPartNo.SetFocus
End If
If Me.txtSerialNo.Value = "" Then
MsgBox "Please enter the Serial No.", vbExclamation, "Missing Serial No."
Me.txtPartNo.SetFocus
End If
'Write Data to Rotable history worksheet'
Set ws = Sheets("Asset History")
Set rFind = ws.Range("A2")
ws.Activate
NewID = rFind + 1
If MsgBox("Add New Asset as Entry ID " & Format(NewID, "") & "?", vbOKCancel, _
"Add New Asset") = vbCancel Then
Exit Sub
End If
Me.EnableEvents = False
Me.txtEntryDate = Date
Me.txtUpdateDate = ""
Me.cboUniqueID.AddItem Format(NewID, ""), 0
Me.cboUniqueID = Format(NewID, "")
rFind.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
Set rFind = rFind.Offset(-1, 0)
With rFind.EntireRow.Font
.ColorIndex = 0
.Bold = False
End With
rFind.Offset(0, 0) = Format(NewID, "")
rFind.Offset(0, 1) = Format(Me.txtEntryDate, "m/dd/yy")
rFind.Offset(0, 2) = Me.txtUpdateDate
rFind.Offset(0, 3) = Me.txtPartNo.Value
rFind.Offset(0, 4) = Me.txtSerialNo.Value
rFind.Offset(0, 5) = Me.txtCost.Value
rFind.Offset(0, 6) = Me.cboShopName.Value
rFind.Offset(0, 7) = Me.txtPurchaseOrderNo.Value
rFind.Offset(0, 8) = Me.txtBuyerName.Value
rFind.Offset(0, 9) = Me.txtNotes.Value
rFind.Offset(0, 10) = Me.cboProfitCenter.Value
rFind.Offset(0, 11) = Me.txtAssetNo.Value
rFind.Offset(0, 12) = Environ$("USERNAME")
Me.EnableEvents = True
Call CheckLists
End Sub
Private Sub cmdUpdate_Click()
Dim rFind As Range
If Me.EnableEvents = False Then Exit Sub
Sheets("Asset History").Activate
Set rFind = ActiveWorkbook.Names("ID").RefersToRange.Find(Format(Me.cboUniqueID.Value, "0"), lookat:=xlWhole)
If rFind Is Nothing Then
MsgBox "Select an Entry ID to update ", vbOKOnly, "No entry found"
Exit Sub
Else
If MsgBox("Update history for ID " & Me.cboUniqueID.Value & " with new values? ", vbOKCancel, "Edit History") = vbCancel Then
Exit Sub
End If
End If
Me.EnableEvents = False
Me.txtUpdateDate = Date
rFind.Offset(0, 1) = Format(Me.txtEntryDate, "m/dd/yy")
rFind.Offset(0, 2) = Format(Me.txtUpdateDate, "m/dd/yy")
If Not rFind.Offset(0, 3) = Me.txtPartNo Then
With rFind.Offset(0, 3)
.Value = Me.txtPartNo
.Font.ColorIndex = 3
.Font.Bold = True
End With
Else
With rFind.Offset(0, 3).Font
.ColorIndex = 0
.Bold = False
End With
End If
If Not rFind.Offset(0, 4) = Me.txtSerialNo Then
With rFind.Offset(0, 4)
.Value = Me.SerialNo
.Font.ColorIndex = 3
.Font.Bold = True
End With
Else
With rFind.Offset(0, 4).Font
.ColorIndex = 0
.Bold = False
End With
End If
If Not rFind.Offset(0, 5) = Me.txtCost Then
With rFind.Offset(0, 5)
.Value = Me.txtCost
.Font.ColorIndex = 3
.Font.Bold = True
End With
Else
With rFind.Offset(0, 5).Font
.ColorIndex = 0
.Bold = False
End With
End If
If Not rFind.Offset(0, 6) = Me.cboShopName Then
With rFind.Offset(0, 6)
.Value = Me.cboShopName
.Font.ColorIndex = 3
.Font.Bold = True
End With
Else
With rFind.Offset(0, 6).Font
.ColorIndex = 0
.Bold = False
End With
End If
If Not rFind.Offset(0, 7) = Me.txtPurchaseOrderNo Then
With rFind.Offset(0, 7)
.Value = Me.txtPurchaseOrderNo
.Font.ColorIndex = 3
.Font.Bold = True
End With
Else
With rFind.Offset(0, 7).Font
.ColorIndex = 0
.Bold = False
End With
End If
If Not rFind.Offset(0, 8) = Me.txtBuyerName Then
With rFind.Offset(0, 8)
.Value = Me.txtBuyerName
.Font.ColorIndex = 3
.Font.Bold = True
End With
Else
With rFind.Offset(0, 8).Font
.ColorIndex = 0
.Bold = False
End With
End If
If Not rFind.Offset(0, 9) = Me.txtNotes Then
With rFind.Offset(0, 9)
.Value = Me.txtNotes
.Font.ColorIndex = 3
.Font.Bold = True
End With
Else
With rFind.Offset(0, 9).Font
.ColorIndex = 0
.Bold = False
End With
End If
If Not rFind.Offset(0, 10).Text = Me.cboProfitCenter Then
With rFind.Offset(0, 10)
.Value = Me.cboProfitCenter
.Font.ColorIndex = 3
.Font.Bold = True
End With
Else
With rFind.Offset(0, 10).Font
.ColorIndex = 0
.Bold = False
End With
End If
rFind.Offset(0, 12) = Environ$("USERNAME")
Me.EnableEvents = True
Call CheckLists
End Sub
Private Sub cbouniqueID_Change()
Dim rFind As Range
If Me.EnableEvents = False Then Exit Sub
Me.txtEntryDate.SetFocus
Set rFind = ActiveWorkbook.Names("ID").RefersToRange.Find(Format(Me.cboUniqueID.Value, "0"), lookat:=xlWhole)
If Not Me.txtPartNo.Value = vbNullString Then
If MsgBox("Are you sure you want to load entry ID " & Me.cboUniqueID.Value & " from history?" & _
vbCrLf & vbCrLf & "This will remove all changes on this form", vbOKCancel, "Mmmm...") = vbCancel Then
Me.EnableEvents = False
Me.cboUniqueID = LastID
Me.EnableEvents = True
Exit Sub
End If
End If
LastID = Me.cboUniqueID
Me.txtEntryDate = rFind.Offset(0, 1)
Me.txtUpdateDate = rFind.Offset(0, 2)
Me.txtPartNo = rFind.Offset(0, 3)
Me.txtSerialNo = rFind.Offset(0, 4)
Me.txtCost = rFind.Offset(0, 5)
Me.cboShopName = rFind.Offset(0, 6)
Me.txtPurchaseOrderNo = rFind.Offset(0, 7)
Me.txtBuyerName = rFind.Offset(0, 8)
Me.txtNotes = rFind.Offset(0, 9)
Me.cboProfitCenter = rFind.Offset(0, 10)
Me.txtAssetNo = rFind.Offset(0, 11)
End Sub
Private Sub FillEmailRange(rFind As Range)
Dim ws As Worksheet
Dim rng As Range
Set ws = Sheets("Asset Form")
Set rng = ws.Range("B1")
rng.Offset(0, 0) = rFind.Offset(0, 3)
rng.Offset(1, 0) = rFind.Offset(0, 4)
rng.Offset(2, 0) = rFind.Offset(0, 5)
rng.Offset(3, 0) = rFind.Offset(0, 6)
rng.Offset(4, 0) = rFind.Offset(0, 7)
rng.Offset(5, 0) = rFind.Offset(0, 8)
rng.Offset(6, 0) = rFind.Offset(0, 9)
rng.Offset(7, 0) = rFind.Offset(0, 10)
rng.Offset(8, 0) = Format(Me.txtEntryDate, "m/dd/yy")
rng.Offset(9, 0) = Format(Me.txtUpdateDate, "m/dd/yy")
rng.Offset(10, 0) = rFind.Offset(0, 11)
rng.Offset(11, 0) = rFind.Offset(0, 12)
rng.Offset(12, 0) = "<" & Format(Me.cboUniqueID, "0000") & ">"
rng.Offset(0, 0).Font.Color = rFind.Offset(0, 3).Font.Color
rng.Offset(1, 0).Font.Color = rFind.Offset(0, 4).Font.Color
rng.Offset(2, 0).Font.Color = rFind.Offset(0, 5).Font.Color
rng.Offset(3, 0).Font.Color = rFind.Offset(0, 6).Font.Color
rng.Offset(4, 0).Font.Color = rFind.Offset(0, 7).Font.Color
rng.Offset(6, 0).Font.Color = rFind.Offset(0, 8).Font.Color
rng.Offset(7, 0).Font.Color = rFind.Offset(0, 9).Font.Color
rng.Offset(8, 0).Font.Color = rFind.Offset(0, 10).Font.Color
rng.Offset(9, 0).Font.Color = rFind.Offset(0, 11).Font.Color
rng.Offset(10, 0).Font.Color = rFind.Offset(0, 12).Font.Color
rng.Offset(1, 0).Font.Bold = rFind.Offset(0, 4).Font.Bold
rng.Offset(2, 0).Font.Bold = rFind.Offset(0, 5).Font.Bold
rng.Offset(3, 0).Font.Bold = rFind.Offset(0, 6).Font.Bold
rng.Offset(4, 0).Font.Bold = rFind.Offset(0, 7).Font.Bold
rng.Offset(6, 0).Font.Bold = rFind.Offset(0, 8).Font.Bold
rng.Offset(8, 0).Font.Bold = rFind.Offset(0, 9).Font.Bold
rng.Offset(9, 0).Font.Bold = rFind.Offset(0, 10).Font.Bold
rng.Offset(10, 0).Font.Bold = rFind.Offset(0, 11).Font.Bold
End Sub
Private Sub cmdSendEmail_Click()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim rowoffset As Integer
Dim EmailTo As String
Dim Subject As String
Dim EmailBody As Range
Dim ws As Worksheet
Dim rFind As Range
Dim ScreenShotTo As String
If MsgBox("Do you want to create email to the distribution List?", vbYesNo, "E-mail Rotable Form") = vbNo Then Exit Sub
Application.ScreenUpdating = False
'Gathers and assembles the distribution list into a single string
Set rFind = ActiveWorkbook.Names("ID").RefersToRange.Find(Format(Me.cboUniqueID.Value, "0"), lookat:=xlWhole)
If rFind Is Nothing Then
MsgBox vbCrLf & "Please add the new Asset to history first. " & vbCrLf, vbOKOnly, "Meow"
Exit Sub
End If
Call FillEmailRange(rFind)
Set rFind = ActiveWorkbook.Names("EmailList").RefersToRange.Find(Me.EmailList, lookat:=xlWhole)
If rFind Is Nothing Then
MsgBox "Please choose a distribution list to E-mail ", vbOKOnly, "List Not Found"
Exit Sub
End If
Set ws = Sheets("Asset Form")
Set EmailBody = ws.Range("A1:B12")
ws.Activate
EmailBody.Select
rowoffset = 1
EmailTo = ""
Do
EmailTo = EmailTo & rFind.Offset(rowoffset, 0).Text & "; "
rowoffset = rowoffset + 1
Loop Until rFind.Offset(rowoffset, 0).Text = ""
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
On Error Resume Next
With OutlookMail
.To = EmailTo
.CC = ""
.BCC = ""
.Subject = "Asset: " & Me.txtPartNo & " " & Me.txtSerialNo & ""
.HTMLBody = RangetoHTML(EmailBody)
.Display
End With
On Error GoTo 0
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub
Private Sub SendEmail_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim EmailBody As Range
Dim EmailTo As String
Dim rowoffset As Integer
Dim rFind As Range
Dim ws As Worksheet
Set rFind = ActiveWorkbook.Names("Asset ID").RefersToRange.Find(Format(Me.cboUniqueID.Value, "0"), lookat:=xlWhole)
If rFind Is Nothing Then
MsgBox vbCrLf & "Please add the new Rotable Asset to history first. " & vbCrLf, vbOKOnly, "Check"
Exit Sub
End If
Call FillEmailRange(rFind)
Set rFind = ActiveWorkbook.Names("EmailList").RefersToRange.Find(Me.cboEmailList, lookat:=xlWhole)
If rFind Is Nothing Then
MsgBox "Please choose a distribution list to E-mail ", vbOKOnly, "List Not Found"
Exit Sub
End If
Set ws = Sheets("Asset Form")
Set EmailBody = ws.Range("A1:B12")
ws.Activate
EmailBody.Select
rowoffset = 1
EmailTo = ""
Do
EmailTo = EmailTo & rFind.Offset(rowoffset, 0).Text & "; "
rowoffset = rowoffset + 1
Loop Until rFind.Offset(rowoffset, 0).Text = ""
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = EmailTo
.CC = ""
.BCC = ""
.Subject = "New Asset Creation: " & " <Part# " & Me.txtPartNo & " <Serial# " & Me.txtSerialNo & ">"
.HTMLBody = RangetoHTML(EmailBody)
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Private Sub CheckLists()
Dim n As Name
Dim iCounter As Integer
Dim wb As Workbook
For Each n In ActiveWorkbook.Names
If InStr(n.Name, "FilterDatabase") = 0 And InStr(n.Name, "Print_Area") = 0 And InStr(n.Name, "ID") = 0 Then
If n.RefersToRange.Find(Me.Controls.Item(n.Name), lookat:=xlWhole) Is Nothing Then
If Not Me.Controls.Item(n.Name) = "" Then
n.RefersToRange.End(xlDown).Offset(1, 0) = Me.Controls.Item(n.Name)
n.RefersToRange.Sort key1:=n.RefersToRange, order1:=xlAscending, Header:=xlYes, DataOption1:=xlSortTextAsNumbers
Me.Controls.Item(n.Name).AddItem Me.Controls.Item(n.Name), 0
End If
End If
End If
Next n
End Sub
Userform Image.PNG
VBA error.PNG
Register To Reply
Bookmarks