-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathInsQOoD.bas
292 lines (232 loc) · 9.4 KB
/
InsQOoD.bas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
Attribute VB_Name = "InsQOoD"
' Attribute VB_Name = "InsQoD"
' Insert Quote of the Day from RSS feed from brainyquote @ feedburner.com, designed and developed by Felix Reta
' felix.reta@live.com
' Copyright 2005 --> 2011
' Tested on Microsoft Outlook 2003, 2007, 2010, 2016
' References to Microsoft Word and Microsoft XML are necessary [Tools --> References]
' Original CommandBar code from Sue Mosher OL MVP circa 2007
' Modified by Felix Reta to add stationery functionality Jan'2012
' Modified for potential HTML change @ brainyquote website/RSS feed May'2013
' Included code to insert quote after string Jan'2018
' References to Microsoft Word and Microsoft XML are necessary [Tools --> References]
Sub InsertQOD()
Dim objMsg As Outlook.MailItem
Set objMsg = Application.CreateItem(olMailItem)
a = objMsg.ConversationIndex
objMsg.Display
Call AddQOD(objMsg)
' Call DeleteSig(objMsg)
Set objMsg = Nothing
End Sub
Sub AddQOD(msg As Outlook.MailItem)
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim objBkm As Word.Bookmark
On Error Resume Next
Set objDoc = msg.GetInspector.WordEditor
Set objSel = objDoc.Application.Selection
With objSel
' .MoveEnd
.EndKey wdStory, wdMove
.Font.name = "Bradley Hand ITC"
.Font.Bold = True
.Font.Italic = False
.Font.Color = wdColorPlum
.Font.Size = 12
.InsertAfter TheDailyQuote
.HomeKey wdStory, wdMove
End With
End Sub
Function TheDailyQuote() As String
Dim My_URL As String
Dim My_Obj As Object
Dim xmlHttp As New XMLHTTP60 'was XMLHTTP30, changed to 60 on Office 2016
Dim My_Var As String
' Dim s As String
Dim My_Quote As String
Dim StrQuoteAuthor As String
Dim IntQuoteStarts As Integer
Dim IntQuoteEnds As Integer
Dim QuotesCount As Integer
Dim AAuthorQuote(10, 2) As String
Dim iNumQuotes As Integer
My_URL = "http://feeds.feedburner.com/brainyquote/QUOTEBR"
' Code modified to obtain specifically the 1st. quote on an RSS feed at: http://feeds.feedburner.com/brainyquote/QUOTEBR
' http://feeds.feedburner.com/brainyquote/QUOTEFU for funny quotes
' My_Obj = CreateObject("MSXML2.XMLHTTP")
xmlHttp.Open "GET", My_URL, False
' My_Obj.Send
xmlHttp.sEnd
' My_Var = My_Obj.responsetext
My_Var = xmlHttp.responseText
' Get Author, should the first <item>, right after a <title> tag
IntQuoteStarts = InStr(1, My_Var, "<item>") ' find the tag of the 1st quote to get the show on the road
My_Var = Mid(My_Var, IntQuoteStarts, Len(My_Var) - IntQuoteStarts)
' This section used to be the main code to obtain the 1st quote, replaced by the iterative function GetQuotes
'right after this tag is the author name, just before /title tag
IntQuoteStarts = InStr(IntQuoteStarts, My_Var, "<title>") + 15
IntQuoteEnds = InStr(IntQuoteStarts, My_Var, "</title>") - IntQuoteStarts - 1
StrQuoteAuthor = Mid(My_Var, IntQuoteStarts + 7, IntQuoteEnds - 6)
' Get the 1st daily quote, should the first string, right after a <description>" tag [Notice triple quotes]
IntQuoteStarts = InStr(1, My_Var, "<description>""") + 13
IntQuoteEnds = InStr(IntQuoteStarts, My_Var, "</description>") - IntQuoteStarts
My_Quote = Mid(My_Var, IntQuoteStarts, IntQuoteEnds)
TheDailyQuote = My_Quote & " - " & StrQuoteAuthor
End Function
Sub InsertQoDHere()
' Dim sText As String
Dim sFile As String
Dim objShape As Object
Dim strDisclaimer As String
Dim FName As String
Dim strFilename As String: strFilename = Environ("UserProfile") & "\Documents\ML-Disclaimer.txt"
Dim strFileContent As String
Dim iFile As Integer: iFile = FreeFile
' sText = TheDailyQuote
On Error GoTo ErrHandler
If TypeName(ActiveWindow) = "Inspector" Then
If ActiveInspector.IsWordMail And ActiveInspector.EditorType = olEditorWord Then
' ActiveInspector.WordEditor.Application.Selection.TypeText sText
ActiveInspector.WordEditor.Application.Selection.TypeText vbCrLf
' Set x = ActiveInspector.WordEditor.Application.Selection
' x.Font.Name = "calibri"
' Read disclaimer text into variable
Open strFilename For Input As #iFile
strDisclaimer = Input(LOF(iFile), iFile)
Close #iFile
FName = Environ("UserProfile") & "\Pictures\Capture-ML-letterhead.png"
' Insert Signature
' Set objShape = objSel.InlineShapes.AddPicture(FName, False, True)
With ActiveInspector.WordEditor.Application.Selection
.Font.name = "Banff-Normal"
.Font.Bold = True
.Font.Italic = False
.Font.Color = wdColorBlue
.Font.Size = 24
.TypeText "Felix Reta "
.Font.name = "Calibri"
.Font.Size = 12
.Font.Subscript = True
.TypeText "PMP " & Chr(169) & vbCrLf
.Font.Subscript = False
.InlineShapes.AddPicture FName
.TypeText vbCrLf
.Font.name = "Calibri"
.Font.Size = 12
.Font.Italic = True
.Font.Color = wdColorGreen
.TypeText "(954) 779-6179" & vbCrLf
' .TypeText "MagicLeap" & vbCrLf
' .HomeKey wdStory, wdMove
End With
With ActiveInspector.WordEditor.Application.Selection
.Font.name = "Calibri"
.Font.Bold = False
.Font.Italic = True
.Font.Color = wdColorBlack
.Font.Size = 14
.TypeText "Technology Vendor Specialist" & vbCrLf
' .HomeKey wdStory, wdMove
End With
' Insert QOD captured in sText
With ActiveInspector.WordEditor.Application.Selection
.Font.name = "Bradley Hand ITC"
.Font.Bold = True
.Font.Italic = False
.Font.Color = wdColorPlum
.Font.Size = 12
.TypeText TheDailyQuote
.TypeText vbCrLf
' .HomeKey wdStory, wdMove
' .Font.Bold = False
' Adding disclaimer
.Font.name = "Helvetica Neue"
.Font.Bold = False
.Font.Color = wdColorBlueGray
.Font.Size = 8
.TypeText strDisclaimer
.HomeKey wdStory, wdMove
End With
End If
End If
Exit Sub
ErrHandler:
Beep
End Sub
Sub ReplyMSG()
Dim olItem As Outlook.MailItem
Dim olReply As MailItem ' Reply
For Each olItem In Application.ActiveExplorer.Selection
Set olReply = olItem.ReplyAll
' olReply.HTMLBody = "Hello, Thank you. " & vbCrLf & olReply.HTMLBody
Call AddQOD(olReply)
olReply.Display
'olReply.Send
Next olItem
End Sub
Sub testing()
Debug.Print Environ("UserProfile") & "\Pictures"
End Sub
Private Sub cmdFileDialog_Click()
' Requires reference to Microsoft Office 11.0 Object Library.
Dim fDialog As Office.FileDialog
Dim varFile As Variant
' Clear listbox contents.
' Me.FileList.RowSource = ""
' Set up the File Dialog.
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
' Allow user to make multiple selections in dialog box
.AllowMultiSelect = True
' Set the title of the dialog box.
.Title = "Please select one or more files"
' Clear out the current filters, and add our own.
.Filters.Clear
.Filters.Add "Access Databases", "*.MDB"
.Filters.Add "Access Projects", "*.ADP"
.Filters.Add "All Files", "*.*"
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show = True Then
'Loop through each file selected and add it to our list box.
For Each varFile In .SelectedItems
Me.FileList.AddItem varFile
Next
Else
msgbox "You clicked Cancel in the file dialog box."
End If
End With
End Sub
Sub c()
' Requires reference to Microsoft Office 11.0 Object Library.
Dim fDialog As Office.FileDialog
Dim varFile As Variant
' Clear listbox contents.
Me.FileList.RowSource = ""
' Set up the File Dialog.
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
' Allow user to make multiple selections in dialog box
.AllowMultiSelect = True
' Set the title of the dialog box.
.Title = "Please select one or more files"
' Clear out the current filters, and add our own.
.Filters.Clear
.Filters.Add "Access Databases", "*.ACCDB"
.Filters.Add "Access Projects", "*.ADP"
.Filters.Add "All Files", "*.*"
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show = True Then
'Loop through each file selected and add it to our list box.
For Each varFile In .SelectedItems
Me.FileList.AddItem varFile
Next
Else
msgbox "You clicked Cancel in the file dialog box."
End If
End With
End Sub