468,514 Members | 1,034 Online
Bytes | Developer Community
New Post

Home Posts Topics Members FAQ

Post your question to a community of 468,514 developers. It's quick & easy.

Change Font in VBA

I included my VBA below. I would like to change the font of the
"strBody" to be Bold, italic, color, etc. The code that I attempted to
write is identified by ***. Any help would be appreciated.
------------------------------------------------
Private Sub EmlAll_Click()

On Error GoTo Err_EmlAll_Click
Dim strBody As String
Dim rs As Object
Dim con As Object
Dim DateEnter As Date
Dim NoMeetings As Integer
Dim Meeting(100) As Integer
Dim i As Integer
Dim j As Integer
Dim Room As String

***Dim fontheader As StdFont
***Dim bold As Boolean
***Dim name As String
***fontheader.bold = True
***fontheader.name = "Arial"

i = 0
j = 0
If Not IsNull(Me![DateEnter]) Then

'this is an sql string to search by date. You'll need to change the name
to fit your database.
sqlst = "Select Distinct MeetingID " _
& "From MeetingData " _
& "WHERE ((MeetingData.MeetingDate) = #" & Me![DateEnter] & "#)"

Set con = Application.CurrentProject.Connection
Set rs = CreateObject("ADODB.recordset")

rs.Open sqlst, con, 1

If Not rs.EOF Then

While Not rs.EOF

Meeting(i) = rs![MeetingID]
i = i + 1
rs.MoveNext
Wend

Else
MsgBox ("No meetings on this date") 'this is your msgbox for the
user to enter the date.
Exit Sub
End If
rs.Close

***Set fontheader.font = strBody

strBody = "Port Assignments: " & Format(Me![DateEnter], "Long Date") &
vbCr
For j = 0 To i

'the following is a sql string that you will need to edit according to
your needs. Enter sql string
'after the sqlst=. There was a problem with carriage returns so leave
undercores in after each line along with ampersands

sqlst = "SELECT MeetingData.MeetingTitle, MeetingData.MeetingDate, " _
& "MeetingData.Description, MeetingData.SetupTime, " _
& "MeetingData.StartTime,MeetingData.EndTime, [Usage].TimeID, " _
& "[Usage].Port,[Usage].DialUpNo " _
& "FROM MeetingData Left JOIN [Usage] ON " _
& "MeetingData.MeetingID=[Usage].MeetingID " _
& "WHERE ((MeetingData.MeetingID) = " & Meeting(j) & ")"

'Set con = Application.CurrentProject.Connection
'Set rs = CreateObject("ADODB.recordset")

rs.Open sqlst, con, 1

If Not rs.EOF Then

strBody = strBody & vbCr
strBody = strBody &
"-------------------------------------------------------------" & vbCr
strBody = strBody & "Subject: " & rs![MeetingTitle] & vbCr
strBody = strBody &
"-------------------------------------------------------------" & vbCr
strBody = strBody & "Setup Time: " & vbTab & Format(TimeSerial(3, 0,
0) + rs![SetupTime], "Short Time") & " E " & Format(TimeSerial(2, 0, 0)
+ rs![SetupTime], "Short Time") & " C " & Format(TimeSerial(1, 0, 0) +
rs![SetupTime], "Short Time") & " M " & Format(rs![SetupTime], "Short
Time") & " P " & vbCr
strBody = strBody & "Start Time: " & vbTab & Format(TimeSerial(3, 0,
0) + rs![StartTime], "Short Time") & " E " & Format(TimeSerial(2, 0, 0)
+ rs![StartTime], "Short Time") & " C " & Format(TimeSerial(1, 0, 0) +
rs![StartTime], "Short Time") & " M " & Format(rs![StartTime], "Short
Time") & " P " & vbCr
strBody = strBody & "End Time: " & vbTab & Format(TimeSerial(3, 0,
0) + rs![EndTime], "Short Time") & " E " & Format(TimeSerial(2, 0, 0) +
rs![EndTime], "Short Time") & " C " & Format(TimeSerial(1, 0, 0) +
rs![EndTime], "Short Time") & " M " & Format(rs![EndTime], "Short
Time") & " P " & vbCr
strBody = strBody & "Description:" & rs![Description] & vbCr & vbCr
strBody = strBody & "Participants" & vbTab & "Port Number" & vbTab &
"Dial Number" & vbCr
While Not rs.EOF
If IsNull(rs![TimeID]) Then
Room = ""
Else
Room = DLookup("RoomName", "TimeCard", "[TimeID] = " &
rs![TimeID])
End If

strBody = strBody & Room & vbTab & vbTab & rs![PortID] & vbTab &
rs![DialUpNo] & vbCr
rs.MoveNext
Wend
strBody = strBody & vbCr & "" & vbCr

End If
rs.Close

Next j

'================================================= ======================
=====================================
'You can edit the myItem.Subject,.To, &.Cc within the quotations. The
myItem.Body refers to the strBody string above
'DO NOT delete the strBody. In the myItem.To, you can input actual
email addresses seperated by a semicolin or exchange name

'================================================= ======================
=====================================
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.createitem(0)
myItem.Subject = "Port Assignments" 'enter your email subject line
here
myItem.Body = strBody
myItem.To = "" 'enter your destination email here
myItem.Cc = ""
myItem.display

Set rs = Nothing

Else
MsgBox ("Please enter a date") 'this is your error msgbox if no date is
entered. you can change this message if you'd like
End If
Exit_EmlAll_Click:
Exit Sub

Err_EmlAll_Click:
MsgBox Err.Description
Resume Exit_EmlAll_Click

End Sub
-------------------------------------------------------
Forgive me...I'm a beginner programmer with expert expectations.

*** Sent via Developersdex http://www.developersdex.com ***
Jul 10 '06 #1
1 11143
Tee GEE wrote:
I included my VBA below. I would like to change the font of the
"strBody" to be Bold, italic, color, etc. The code that I attempted to
write is identified by ***. Any help would be appreciated.
I think you need something additional to the current features in Access.
You might want to check out http://www.lebans.com/richtext.htm. Also,
check out any other offering Stephen may have regarding RTF via his
search field.

SendObject allows you to send an Email formatted RTF...but it appears
that in your case you need to get the body of the message into RTF
format first.
------------------------------------------------
Private Sub EmlAll_Click()

On Error GoTo Err_EmlAll_Click
Dim strBody As String
Dim rs As Object
Dim con As Object
Dim DateEnter As Date
Dim NoMeetings As Integer
Dim Meeting(100) As Integer
Dim i As Integer
Dim j As Integer
Dim Room As String

***Dim fontheader As StdFont
***Dim bold As Boolean
***Dim name As String
***fontheader.bold = True
***fontheader.name = "Arial"

i = 0
j = 0
If Not IsNull(Me![DateEnter]) Then

'this is an sql string to search by date. You'll need to change the name
to fit your database.
sqlst = "Select Distinct MeetingID " _
& "From MeetingData " _
& "WHERE ((MeetingData.MeetingDate) = #" & Me![DateEnter] & "#)"

Set con = Application.CurrentProject.Connection
Set rs = CreateObject("ADODB.recordset")

rs.Open sqlst, con, 1

If Not rs.EOF Then

While Not rs.EOF

Meeting(i) = rs![MeetingID]
i = i + 1
rs.MoveNext
Wend

Else
MsgBox ("No meetings on this date") 'this is your msgbox for the
user to enter the date.
Exit Sub
End If
rs.Close

***Set fontheader.font = strBody

strBody = "Port Assignments: " & Format(Me![DateEnter], "Long Date") &
vbCr
For j = 0 To i

'the following is a sql string that you will need to edit according to
your needs. Enter sql string
'after the sqlst=. There was a problem with carriage returns so leave
undercores in after each line along with ampersands

sqlst = "SELECT MeetingData.MeetingTitle, MeetingData.MeetingDate, " _
& "MeetingData.Description, MeetingData.SetupTime, " _
& "MeetingData.StartTime,MeetingData.EndTime, [Usage].TimeID, " _
& "[Usage].Port,[Usage].DialUpNo " _
& "FROM MeetingData Left JOIN [Usage] ON " _
& "MeetingData.MeetingID=[Usage].MeetingID " _
& "WHERE ((MeetingData.MeetingID) = " & Meeting(j) & ")"

'Set con = Application.CurrentProject.Connection
'Set rs = CreateObject("ADODB.recordset")

rs.Open sqlst, con, 1

If Not rs.EOF Then

strBody = strBody & vbCr
strBody = strBody &
"-------------------------------------------------------------" & vbCr
strBody = strBody & "Subject: " & rs![MeetingTitle] & vbCr
strBody = strBody &
"-------------------------------------------------------------" & vbCr
strBody = strBody & "Setup Time: " & vbTab & Format(TimeSerial(3, 0,
0) + rs![SetupTime], "Short Time") & " E " & Format(TimeSerial(2, 0, 0)
+ rs![SetupTime], "Short Time") & " C " & Format(TimeSerial(1, 0, 0) +
rs![SetupTime], "Short Time") & " M " & Format(rs![SetupTime], "Short
Time") & " P " & vbCr
strBody = strBody & "Start Time: " & vbTab & Format(TimeSerial(3, 0,
0) + rs![StartTime], "Short Time") & " E " & Format(TimeSerial(2, 0, 0)
+ rs![StartTime], "Short Time") & " C " & Format(TimeSerial(1, 0, 0) +
rs![StartTime], "Short Time") & " M " & Format(rs![StartTime], "Short
Time") & " P " & vbCr
strBody = strBody & "End Time: " & vbTab & Format(TimeSerial(3, 0,
0) + rs![EndTime], "Short Time") & " E " & Format(TimeSerial(2, 0, 0) +
rs![EndTime], "Short Time") & " C " & Format(TimeSerial(1, 0, 0) +
rs![EndTime], "Short Time") & " M " & Format(rs![EndTime], "Short
Time") & " P " & vbCr
strBody = strBody & "Description:" & rs![Description] & vbCr & vbCr
strBody = strBody & "Participants" & vbTab & "Port Number" & vbTab &
"Dial Number" & vbCr
While Not rs.EOF
If IsNull(rs![TimeID]) Then
Room = ""
Else
Room = DLookup("RoomName", "TimeCard", "[TimeID] = " &
rs![TimeID])
End If

strBody = strBody & Room & vbTab & vbTab & rs![PortID] & vbTab &
rs![DialUpNo] & vbCr
rs.MoveNext
Wend
strBody = strBody & vbCr & "" & vbCr

End If
rs.Close

Next j

'================================================= ======================
=====================================
'You can edit the myItem.Subject,.To, &.Cc within the quotations. The
myItem.Body refers to the strBody string above
'DO NOT delete the strBody. In the myItem.To, you can input actual
email addresses seperated by a semicolin or exchange name

'================================================= ======================
=====================================
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.createitem(0)
myItem.Subject = "Port Assignments" 'enter your email subject line
here
myItem.Body = strBody
myItem.To = "" 'enter your destination email here
myItem.Cc = ""
myItem.display

Set rs = Nothing

Else
MsgBox ("Please enter a date") 'this is your error msgbox if no date is
entered. you can change this message if you'd like
End If
Exit_EmlAll_Click:
Exit Sub

Err_EmlAll_Click:
MsgBox Err.Description
Resume Exit_EmlAll_Click

End Sub
-------------------------------------------------------
Forgive me...I'm a beginner programmer with expert expectations.

*** Sent via Developersdex http://www.developersdex.com ***
Jul 11 '06 #2

This discussion thread is closed

Replies have been disabled for this discussion.

Similar topics

8 posts views Thread by S.W. Rasmussen | last post: by
16 posts views Thread by Coder Droid | last post: by
9 posts views Thread by Dr John Stockton | last post: by
3 posts views Thread by (Pete Cresswell) | last post: by
2 posts views Thread by Hariharan S | last post: by
2 posts views Thread by Jim | last post: by
3 posts views Thread by Phil Stanton | last post: by
5 posts views Thread by _Who | last post: by
reply views Thread by NPC403 | last post: by
1 post views Thread by fmendoza | last post: by
By using this site, you agree to our Privacy Policy and Terms of Use.