My project is to send fields before Visual Studio to Outlook Body in fields entered in the body after the reception of messages the user can modify the data sent in text fields on Outlook and sends the update data it will be saved in database that's possible to update data from outlook to Database ?
I have build a solution like that, I use it daily to read and file mail as part of my daily workflow. But as others have hinted you need to be specific about what you need help with.
If (TypeOf olItem Is Outlook.MailItem) Then
Dim olMailItem As Outlook.MailItem = TryCast(olItem, Outlook.MailItem)
If olMailItem.Permission = Outlook.OlPermission.olUnrestricted Then
strBody = olMailItem.HTMLBody 'file:///C:/AttSave/header.png
Else
strBody = "Rights Protected fix if I'm not in debugger"
End If
For Each olAttach In olMailItem.Attachments
If olAttach.Type <> Outlook.OlAttachmentType.olOLE Then
olAttach.SaveAsFile("c:\AttSave\" & olAttach.FileName)
'strBody = strBody.Replace("cid:header", "file:///C:/AttSave/header.png")
strCID = olAttach.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001E")
If strCID <> "" Then
strBody = strBody.Replace("cid:" & strCID, "file:///C:/AttSave/" & System.Web.HttpUtility.UrlEncode(olAttach.FileName))
End If
lst_Attach.Items.Add(olAttach.FileName)
Else
MsgBox("open this one via outlook")
End If
Next
Me.webBody.DocumentText = strBody
Me.txtSubject.Text = olMailItem.Subject
If olMailItem.Importance = Outlook.OlImportance.olImportanceHigh Then
Me.txtSubject.ForeColor = Color.Red
Else
Me.txtSubject.ForeColor = Color.White
End If
'Dim palSender As Microsoft.Office.Interop.Outlook.AddressEntry
'palSender = mailItem.Sender
Me.txtSentDate.Text = olMailItem.SentOn
'Me.txtTo.Text = olMailItem.To
olSenderA = olMailItem.Sender
If IsNothing(olSenderA) = False Then
'Dim olConItem As Outlook.ContactItem
'olConItem = olSenderA.GetContact()
'If Not IsNothing(olConItem) Then
' If olConItem.HasPicture = True Then
' Stop
' End If
'End If
Pa = olSenderA.PropertyAccessor
'Debug.Print(olRe.Name & "stp= " & Pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E"))
Try
Me.txtFrom.Text = Me.txtFrom.Text & olSenderA.Name & " (" & Pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E") & ")"
Catch ex As System.Runtime.InteropServices.COMException
'Stop
Me.txtFrom.Text = olMailItem.SenderName & " (" & olMailItem.SenderEmailAddress & ")"
Catch ex As Exception
Stop
End Try
Related
My Excel database generates a word document (when a button is clicked) from data the user enters into the database and opens an outlook email with the document attached automatically. When the email pops up with the attachment, the attachment name always has %20 in between the first and last name. I know this is because there is a blank space between the first and last name. Is there a way to remove the %20 and keep the blank space?
My Code
Option Explicit
Sub CreateWordDocuments()
'CREATE A WORD DOCUMENT TO TRANSFER INFORMATION FROM FILTERED
DATA
INTO A WORD TEMPLATE
Dim VSCRow, VSCCol, LastRow, TemplRow, MonthNumber, FromMonth,
ToMonth, DaysOfMonth, FromDays, ToDays As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp, OutApp, OutMail As Object
Dim WordContent As Word.Range
With Sheet5
If .Range("B3").Value = Empty Then
MsgBox "Please select the correct template from the drop down
list"
.Range("F4").Select
Exit Sub
End If
TemplRow = .Range("B3").Value ' Set the Template Value
TemplName = .Range("F4").Value ' Set Template Name
MonthNumber = .Range("V4").Value 'Set the Month Number
FromMonth = .Range("W4").Value
ToMonth = .Range("Y4").Value
DaysOfMonth = .Range("AA4").Value
FromDays = .Range("AC4").Value
ToDays = .Range("AF4").Value
DocLoc = Sheet10.Range("F" & TemplRow).Value ' Word Document
Filename
'Open Word Template
On Error Resume Next 'If Word is already open
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
' Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If
LastRow = .Range("E99999").End(xlUp).Row 'Determine the last Row
For VSCRow = 8 To LastRow
MonthNumber = .Range("X" & VSCRow).Value
DaysOfMonth = .Range("AF" & VSCRow).Value
If TemplName <> .Range("Z" & VSCRow).Value And MonthNumber >=
FromMonth And MonthNumber <= ToMonth And DaysOfMonth >= FromDays
And DaysOfMonth <= ToDays Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc,
ReadOnly:=False) ' Open Template
For VSCCol = 5 To 42 'Move through the colunms for
information
TagName = .Cells(7, VSCCol).Value 'Tag Name
TagValue = .Cells(VSCRow, VSCCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Forward:True,
Wrap:=wdFindContinue
End With
Next VSCCol
If .Range("H4").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("E" &
VSCRow).Value & ".pdf" ' Create full filename and path with
current
workbook
WordDoc.ExportAsFixedFormat OutputFileName:=FileName,
ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else:
FileName = ThisWorkbook.Path & "\" & .Range("E" &
VSCRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
.Range("Z" & VSCRow).Value = TemplName 'Template Name to use
.Range("AA" & VSCRow).Value = Now
If .Range("S4").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application") 'Create Outlook
Application
Set OutMail = OutApp.CreateItem(0) 'Create The Email
With OutMail
.To = Sheet5.Range("Y" & VSCRow).Value
.Subject = "Performance Metrics Verification, " &
Sheet5.Range("R"
& VSCRow).Value & " - " & Sheet5.Range("S" & VSCRow).Value & ", "
& Sheet5.Range("T" & VSCRow).Value.Body = "Good afternoon, " &
Sheet5.Range("E" & VSCRow).Value & ",here are your " &
Sheet5.Range("R" & VSCRow).Value & " - " &
Sheet5.Range("S" & VSCRow).Value & ", " & Sheet5.Range("T" &
VSCRow).Value & " performance metrics as captured by the WFW
database systems. Please review and sign. Comments may be
included
in the email body. Please return to me by COB " &
Sheet5.Range("AG"
& VSCRow).Value & ", If this date falls on a holiday, return on
the
next business day following the holiday."
.Attachments.Add FileName
.Display 'To send without displaying .Display to .Send
End With
Else
WordDoc.PrintOut
WordDoc.Close
End If
Kill (FileName) 'Deletes the PDF or Word that was just
created
End If '3 conditions are met
Next VSCRow
WordApp.Quit
End With
End Sub
Attachment with %20 between name
Can someone help me. I'm having a hard time with this. All I need is to display an alert message whenever the medicines expired.My problem is when I got two or more expired medicines it doesn't alert all.Instead it alerts one medicine.Please help.
here is my code
Private Sub Form_Activate()
On Error Resume Next
With Main
.Text4 = Adodc1.Recordset.Fields("MedicineName")
.Text1.Text = Adodc1.Recordset.Fields("genericname")
.Text3.Text = Adodc1.Recordset.Fields("StockQuantity")
.Combo3 = Adodc1.Recordset.Fields("Expmonth")
.Combo4 = Adodc1.Recordset.Fields("Expday")
.Combo5 = Adodc1.Recordset.Fields("Expyear")
End With
Dim expirationdate As Date
expirationdate = CDate(Combo3 & "/" & Combo4 & "/" & Combo5)
datepicker.Value = Format(Now, "MMM-DD-yyyy")
If datepicker > expirationdate Then
MsgBox Text4.Text & " is expired ", vbExclamation, "Warning!"
If MsgBox("Do you want to dispose " & Text4 & "?", vbQuestion + vbYesNo, "Message") = vbYes Then
Adodc1.Recordset.Delete
ElseIf vbNo Then
Exit Sub
End If
End If
End Sub
Private Sub Form_Load()
Adodc1.CommandType = adCmdUnknown
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\clinic.mdb" & ";Persist Security Info=False"
Adodc1.RecordSource = "select * from inventory order by Expyear asc"
Adodc1.Refresh
Adodc1.Refresh
End sub
You need to loop through all of the records in your recordset. Currently, you're operating on the FIRST record only.
Do Until Adodc1.Recordset.EOF
' Assign values to textboxes, test date, etc.
' Fetch the next record...
Adodc1.Recordset.MoveNext
Loop
Bond is correct, you need to iterate over your recordset to display the message for each record that is expired.
Private Sub Form_Activate()
Dim expirationdate As Date
On Error Resume Next '<-- this is going to cause a problem if you never check for errors
Adodc1.Recordset.MoveFirst 'make sure the control is positioned on the first record
Do While Adodc1.Recordset.EOF = False 'loop over all of the records
With Main
.Text4.Text = Adodc1.Recordset.Fields("MedicineName")
.Text1.Text = Adodc1.Recordset.Fields("genericname")
.Text3.Text = Adodc1.Recordset.Fields("StockQuantity")
.Combo3 = Adodc1.Recordset.Fields("Expmonth")
.Combo4 = Adodc1.Recordset.Fields("Expday")
.Combo5 = Adodc1.Recordset.Fields("Expyear")
End With
expirationdate = CDate(Combo3 & "/" & Combo4 & "/" & Combo5)
datepicker.Value = Format(Now, "MMM-DD-yyyy")
If datepicker > expirationdate Then
MsgBox Text4.Text & " is expired ", vbExclamation, "Warning!"
If MsgBox("Do you want to dispose " & Text4 & "?", vbQuestion + vbYesNo, "Message") = vbYes Then
Adodc1.Recordset.Delete
End If
End If
Adodc1.Recordset.MoveNext
Loop
End Sub
I have set this up to auto email through the Outlook client, is it possible to change this code to work directly through an SMTP server? And could anyone possibly help me do it?
Any help would be much appreciated, thanks!
Set app = CreateObject("Excel.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f In fso.GetFolder("Y:\Billing_Common\autoemail").Files
If LCase(fso.GetExtensionName(f)) = "xls" Then
Set wb = app.Workbooks.Open(f.Path)
set sh = wb.Sheets("Auto Email Script")
row = 2
name = "Customer"
email = sh.Range("A" & row)
subject = "Billing"
the = "the"
LastRow = sh.UsedRange.Rows.Count
For r = row to LastRow
If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then
SendMessage email, name, subject, TRUE, _
NULL, "Y:\Billing_Common\autoemail\Script\energia-logo.gif", 143,393
row = row + 1
email = sh.Range("A" & row)
End if
Next
wb.Close
End If
Next
Sub SendMessage(EmailAddress, DisplayName, Subject, DisplayMsg, AttachmentPath, ImagePath, ImageHeight, ImageWidth)
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
template = FindTemplate()
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(EmailAddress)
objOutlookRecip.resolve
objOutlookRecip.Type = 1
' Set the Subject, Body, and Importance of the message.
.Subject = Subject
.bodyformat = 3
.Importance = 2 'High importance
body = Replace(template, "{First}", name)
body = Replace(body, "{the}", the)
if not isNull(ImagePath) then
if not ImagePath = "" then
.Attachments.add ImagePath
image = split(ImagePath,"\")(ubound(split(ImagePath,"\")))
body = Replace(body, "{image}", "<img src='cid:" & image & _
"'" & " height=" & ImageHeight &" width=" & ImageWidth & ">")
end if
else
body = Replace(body, "{image}", "")
end if
if not isNull(AttachMentPath) then
.Attachments.add AttachmentPath
end if
.HTMLBody = body
.Save
.Send
End With
Set objOutlook = Nothing
End Sub
Function FindTemplate()
Set OL = GetObject("", "Outlook.Application")
set Drafts = OL.GetNamespace("MAPI").GetDefaultFolder(16)
Set oItems = Drafts.Items
For Each Draft In oItems
If Draft.subject = "Template" Then
FindTemplate = Draft.HTMLBody
Exit Function
End If
Next
End Function
If you want to send mail directly to an SMTP server, there's no need to go through Outlook in the first place. Just use CDO. Something like this:
schema = "http://schemas.microsoft.com/cdo/configuration/"
Set msg = CreateObject("CDO.Message")
msg.Subject = "Test"
msg.From = "sender#example.com"
msg.To = "recipient#example.org"
msg.TextBody = "This is some sample message text."
With msg.Configuration.Fields
.Item(schema & "sendusing") = 2
.Item(schema & "smtpserver") = "smtp.intern.example.com"
.Item(schema & "smtpserverport") = 25
.Update
End With
msg.Send
I have a VB6 front end, SQL Server 2005 as the back end and Crystal Reports 8.5 for reports.
I need to set the location at run time in my application as I have 2 databases. My problem is that when I change database, but the location remain the same. It will be great if anyone can help me out. Thanks in advance for your time, and here is my code.
Private Sub prin_Click()
With CrystalReport1
.Connect = MDI1.txtcn --> this is my connection info "driver={sql server};server=server;database=database;uid=user;pwd=password"
.DiscardSavedData = True
.Action = 1
.PrintReport
End With
Try some code like this:
Private Sub cmdSetLocations_Click()
Dim CrxApp As New CRAXDRT.Application
Dim CrxRep As CRAXDRT.Report
Dim CrxSubRep As CRAXDRT.Report
Dim strReport As String
Dim i As Integer, ii As Integer
strReport = "[Path to report file]"
Set CrxRep = CrxApp.OpenReport(strReport)
SetReportLocation CrxRep
For i = 1 To CrxRep.Sections.Count
For ii = 1 To CrxRep.Sections(i).ReportObjects.Count
If CrxRep.Sections(i).ReportObjects(ii).Kind = crSubreportObject Then
Set CrxSubRep = CrxRep.OpenSubreport(CrxRep.Sections(i).ReportObjects(ii).SubreportName)
SetReportLocation CrxSubRep
End If
Next ii
Next
'open your report in the report viewer
Set CrxApp = Nothing
Set CrxRep = Nothing
Set CrxSubRep = Nothing
End Sub
Private Sub SetReportLocation(ByRef RepObj As CRAXDRT.Report)
Dim CrxDDF As CRAXDRT.DatabaseTable
Dim CP As CRAXDRT.ConnectionProperties
For Each CrxDDF In RepObj.Database.Tables
Set CP = CrxDDF.ConnectionProperties
CP.DeleteAll
CP.Add "Connection String", "[Your connection string goes here]"
Next
Set CrxDDF = Nothing
Set CP = Nothing
End Sub
With CR
.ReportFileName = App.Path + "\Labsen2.rpt"
.SelectionFormula = "{PersonalCalendar.PersonalCalendarDate}>= Date(" & Year(DTPicker1) & "," & Month(DTPicker1) & "," & Day(DTPicker1) & ") and {PersonalCalendar.PersonalCalendarDate}<=date(" & Year(DTPicker2) & "," & Month(DTPicker2) & "," & Day(DTPicker2) & ") and {Department.DepartmentName}= '" & Combo1.Text & "'"
.Formulas(0) = "tglAwal = '" & DTPicker1.Value & "'"
.Formulas(1) = "tglAkhir = '" & DTPicker2.Value & "'"
.Password = Chr(10) & "ithITtECH"
.RetrieveDataFiles
.WindowState = crptMaximized
.Action = 1
End With
Try formatting the connection string like this:
DSN=server;UID=database;PWD=password;DSQ=user
The meanings of DSN, UID, DSQ are counter-intuitive, they are overloaded by Crystal.
Also check you have no subreports whose Connect properties would need to be similarly changed.
Why not pass the recordset to your report? In this way you will be able to get data from any supported (i mean VB6 can connect to) databases dynamically, you can even merge data from multiple databases, your report will require the data(recordset) only and report will be created with Data Field Definition.
I want to write a VBS macro to auto generate an email in outlook and attach a word document. I currently have a macro that does this for excel, but I can't get it to work for Word. I can't figure out for the life of me what my "FName= " should be. Any suggestions or help would be greatly appreciated. Here is what I have:
Sub AutoEmail()
On Error GoTo Cancel
Dim Resp As Integer
Resp = MsgBox(prompt:=vbCr & "Yes = Review Email" & vbCr & "No = Immediately Send" & vbCr & "Cancel = Cancel" & vbCr, _
Title:="Review email before sending?", _
Buttons:=3 + 32)
Select Case Resp
'Yes was clicked, user wants to review email first
Case Is = 6
Dim myOutlook As Object
Dim myMailItem As Object
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = ActiveWord & "\" & ActiveWord.Name
With otlNewMail
.To = ""
.CC = ""
.Subject = ""
.Body = "Good Morning," & vbCr & vbCr & "" & Format(Date, "MM/DD") & "."
.Attachments.Add FName
.Display
End With
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
'If no is clicked
Case Is = 7
Dim myOutlok As Object
Dim myMailItm As Object
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With otlNewMail
.To = ""
.CC = ""
.Subject = ""
.Body = "Good Morning," & vbCr & vbCr & " " & Format(Date, "MM/DD") & "."
.Attachments.Add FName
.Send
'.Display
'Application.Wait (Now + TimeValue("0:00:01"))
'Application.SendKeys "%s"
End With
'otlApp.Quit
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
'If Cancel is clicked
Case Is = 2
Cancel:
MsgBox prompt:="No Email has been sent.", _
Title:="EMAIL CANCELLED", _
Buttons:=64
End Select
End Sub
May it is a bit late, but I want to solve it for future use.
You want to have the active document as your file name (FName).
FName = Application.ActiveDocument.Path + "\" + Application.ActiveDocument.Name
' .Path returns only the Path where the file is saved without the file name like "C:\Test"
' .Name returns only the Name of the file, including the current type like "example.doc"
' Backslash is needed because of the missing backslash from .Path
otlNewMail.Attachements.Add FName
May you also want to save your current document before sending it via outlook, otherwise you will send the document without the changes made.
Function SaveDoc()
ActiveDocument.Save
End Function
I hope that this will help others, because the code from the question helped me a lot while scripting a similar script.