Office VBA Macros You Can Use Today phần 7 pdf

Word Procedures Wrd 'The user didn't select any text; a bookmark without¶ 'content will be inserted with¶ 'an incremented name txt#¶ 'Calculate that name¶ BookmarkName = "txt" & va

Word Procedures

Wrd

'Variable declaration¶

Dim frm As frmUserInput¶

Dim doc As Word.Document¶

Set doc = ActiveDocument¶

If doc.Bookmarks.Count < 1 Then¶

MsgBox "Invalide document " & _¶

"No bookmarks could be found.", _¶

Dim firstControl As Boolean¶

For Each ctl In frm.Controls¶

Word Procedures

Wrd

Follow these steps:

1 Copy the macro code to the correspondence template's VBA project

2 Transfer the UserForm frmUserInput to the same project using either

the Organizer, or by dragging it in the Visual Basic Editor (VBE) to the

template's project The code for this UserForm module is below for

The code in the example file also includes the 'basCreateBookmark' module,

which is utilized in the Creating a Bookmark from a Selection entry found on

page 260 It is included below for reference

Option explicit¶

' * * * * *¶

Const varName As String = "BookmarkCounter"¶

Const varDuplicateName As String _¶

Dim BookmarkName As String¶

Dim var As Word.Variable¶

'Check whether the document variable that stores¶

'a counter for bookmarks without content exists¶

If varExists(ActiveDocument, varName) = False Then¶

'If not, create it and assign it the value 1¶

Word Procedures

Wrd

'The user didn't select any text; a bookmark without¶

'content will be inserted with¶

'an incremented name txt#¶

'Calculate that name¶

BookmarkName = "txt" & var.Value¶

var.Value = CStr(CLng(var.Value) + 1)¶

'Alternately, a prompt can be displayed¶

'to ask the user for the name¶

'Uncomment the next two lines to use that method¶

'Check if the bookmark name already exists;¶

'if it does it will be incremented with a counter¶

BookmarkName = "txt" & CheckIfDuplicateName( _¶

'Maximum length of a bookmark name is 40 characters¶

'Because txt will be added to the beginning¶

'therefore cut off at 37¶

If Len(s) > 37 Then s = Left(s, 37)¶

'Replace all spaces with underline characters¶

s = Replace(s, " ", "_")¶

'Remove any numbers at the beginning¶

Do While IsNumeric(Left(s, 1)) = True¶

s = Mid(s, 2)¶

Debug.Print s¶

Loop¶

'Remove invalid characters¶

'(following list is not comprehensive)¶

Function CheckIfDuplicateName(doc As Word.Document, _¶

BookmarkName As String) As String¶

'Variable declaration¶

Dim var As Word.Variable¶

If varExists(doc, varDuplicateName) = False Then¶

'Loop through the list of document variables¶

'and check whether it already exists by¶

'comparing the name¶

For Each var In doc.Variables¶

3 Create bookmarks in the template where the data items in the form

should be inserted (select the location, then Insert | Bookmark) The

bookmark names should match the names of the text boxes in the

UserForm Some of the text boxes used in the example are txtRecipient,

txtStreetAddress, and txtCity

4 To see and change the text box names in the Visual Basic Editor (VBE),

click on a text box and then look at the Name information in the

Properties window (it is usually the first entry listed) Type the correct

name in the box if changes need to be made

Word Procedures

Wrd

Tip: See the following entry, Creating a Bookmark from a Selection, for a tool to quickly create

bookmarks from text selections

5 Insert a bookmark named txtStartBody in the location where the user should start typing once the macro has finished Deciding not to use a bookmark simply means that the macro skips selecting that location if a bookmark isn't present

6 Feel free to change the form to fit various requirements Deleting and adding labels and text boxes won’t detrimentally affect the macro tool Just be careful not to delete the buttons

7 This tool contains an 'AutoNew' procedure so that the form appears whenever the user creates a new document from the template

Comment out the procedure if this is unwanted

8 To make it easy to edit the input at a later time, assign the procedure 'GetUserInput' to a toolbar button The macro automatically picks up the bookmarked content when it displays the user form

Creating a Bookmark from a Selection

This procedure creates a bookmark from the current selection in a document and bases the bookmark name on the selected text

Example file:

W038

Scenario: Using a macro to place text into a Word

document, whether the text originates from a UserForm, a

database, or an InputBox, requires that a target be specified

in the document Most often, bookmarks serve as targets

Bookmarks are also used to mark information for

cross-referencing and generating Tables of Content for specific

parts of a document

While creating bookmarks is simple enough—select a range

of characters, then Insert | Bookmark, type in a name and

click Insert—it is time-consuming to repeatedly go through

the menu and display the dialog box

Word Procedures

Wrd

The following macro bookmarks the current selection in the document, using

the selected text as the bookmark name If the selection is long, only the first

40 characters (maximum number of characters for a bookmark name) are used

Invalid characters will be removed, according to the following rules:

¾ Bookmark names may not begin with numbers Any numbers at the

beginning of a selection are cut off from the bookmark name

¾ Punctuation, such as periods and commas, are not allowed and are

removed

¾ Spaces are replaced with underscores

View the Appendix to learn how to store this procedure

in a Standard module

Option explicit¶

' * * * * *¶

Const varName As String = "BookmarkCounter"¶

Const varDuplicateName As String _¶

Dim BookmarkName As String¶

Dim var As Word.Variable¶

'Check whether the document variable that stores¶

'a counter for bookmarks without content exists¶

If varExists(ActiveDocument, varName) = False Then¶

'If not, create it and assign it the value 1¶

If Selection.Type = wdSelectionIP Then¶

'The user didn't select any text; a bookmark without¶

'content will be inserted with¶

'an incremented name txt#¶

'Calculate that name¶

BookmarkName = "txt" & var.Value¶

var.Value = CStr(CLng(var.Value) + 1)¶

'Alternately, a prompt can be displayed¶

'to ask the user for the name¶

'Uncomment the next two lines to use that method¶

'BookmarkName = InputBox( _¶

'No text is selected Type in a bookmark name.")¶

Else¶

Word Procedures

Wrd

BookmarkName = ProcessBookmarkName(rng.Text)¶

End If¶

'Check if the bookmark name already exists;¶

'if it does, it is incremented with a counter¶

BookmarkName = "txt" & CheckIfDuplicateName( _¶

'Maximum length of a bookmark name is 40 characters¶

'Because txt will be added to the beginning¶

'therefore cut off at 37¶

If Len(s) > 37 Then s = Left(s, 37)¶

'Replace all spaces with underline characters¶

s = Replace(s, " ", "_")¶

'Remove any numbers at the beginning¶

Do While IsNumeric(Left(s, 1)) = True¶

s = Mid(s, 2)¶

Debug.Print s¶

Loop¶

'Remove invalid characters¶

'(following list is not comprehensive)¶

Function CheckIfDuplicateName(doc As Word.Document, _¶

BookmarkName As String) As String¶

'Variable declaration¶

Dim var As Word.Variable¶

If varExists(doc, varDuplicateName) = False Then¶

'Loop through the list of document variables¶

'and check whether it already exists by¶

'comparing the name¶

For Each var In doc.Variables¶

Follow these steps:

1 Copy the entire set of macros to a module in the document, in its

template, in Normal.dot, or in any template that will be loaded as a

global Add-in Then assign it to a toolbar button and/or keyboard

shortcut See Running a Macro from a Toolbar Button on page 418 or

Running a Macro Using Shortcut Keys on page 419 for help in assigning

a macro to a toolbar button or a keyboard shortcut

2 The incremental numbers for duplicate names and bookmarks without

content are stored in document Variables The names for the Variables

are set as Const values at the beginning of the module To use different

names, change the values in quotation marks

3 To type in a bookmark name when no text is selected to provide the

bookmark name, remove the apostrophes from the lines of code below,

and comment out the original code:

If Selection.Type = wdSelectionIP Then¶

'The user didn't select any text; a bookmark without¶

'content will be inserted with¶

'an incremented name txt#¶

'Calculate that name¶

BookmarkName = "txt" & var.Value¶

var.Value = CStr(CLng(var.Value) + 1)¶

Word Procedures

Wrd

'to ask the user for the name¶

'Uncomment the next two lines to use that method¶

'BookmarkName = InputBox( _¶

'No text is selected Type in a bookmark name.")¶

Else¶

Making Bookmarks Visible

With this procedure, you can highlight bookmarks in a document and place their names in comments to make them easier to manage

Example file:

W039

Tip: In Word 2002 and 2003, comments can be displayed in the right margin, with connecting

lines In Word 97, Word 2000, and Word 2003, the bookmark name appears in tip flags when the mouse hovers over a comment

View the Appendix to learn how to store this procedure

ElseIf Selection.Type = wdSelectionNormal Then¶

Scenario: When setting up a document with many

bookmarks, it is often difficult to keep track of their locations

and names One way to obtain an overview is to highlight

them, and put their names in comments

To change the highlight color, delete the text = wdYellow; type the equals sign (=)

again, and a list of values should appear Select one of the values and press Enter

Forcing the User to Enable Macros

These procedures provide methods to prevent users from successfully working

with a document if macros are not enabled

Example file:

WordProtection.doc, DocFromCode.doc, WeeklyReport.xls

Generating the Document Usi ng VBA

Certainly, the most effective way is to generate the entire document when it is

opened or created from a template The 'Document_Open' and 'AutoOpen'

procedures fire when a document is opened A 'Document_New' or 'AutoNew'

procedure fires when a new document is created from a template

In the document body, place a message telling the user how to enable macro

security so that the document can be created If macros can be run, a macro

removes the message text and replaces it with the document, as shown by the

following sample code

Tip: To open one of the sample documents without the AutoOpen macros running, hold down

the Shift key while it is opening Holding the Shift key down when opening a file prevents

macros from executing If this step is forgotten (happens all the time), just close the

Scenario: When distributing macros that manage

templates or documents, it is important that the user have

macros enabled; otherwise the macros won't work For

obvious reasons, it is not possible to create a macro that

changes macro security settings; if it were, macro security

would be useless This section discusses a number of ways

to prevent the user from working with a project unless

macros are enabled There are a couple of code examples

to demonstrate how the techniques are applied

'Path to be used in the field code¶

'linking in the Excel file¶

'Field codes need double backslashes¶

Const ReportPath As String = "C:\\test\\WeeklyReport.xls"¶

Text:="no macro " & _¶

"Click here and type East coast regional sales info", _¶ PreserveFormatting:=False)¶

Text:="LINK Excel.Sheet.8 " & Chr$(34) _¶

& ReportPath & Chr$(34) & " " & Chr$(34) _¶

& "EastCoast!EastCoast" & Chr$(34) _¶

Word Procedures

Wrd

View the Appendix to learn how to store this procedure

in the ThisDocument module

Using Forms Protection

Generating an entire document from scratch can be a challenge Somewhat

easier is the method of protecting the file as a Word form (don’t confuse this

with a UserForm) with a password by using Tools | Protect document The

'Document_Open', 'Auto Open', 'Document_New', or 'AutoNew' procedure can be

built to remove the protection and do any other preparatory work (such as

removing a message to the user at the beginning of the document about

activating macro security), as this sample code demonstrates

View the Appendix to learn how to store this procedure

The only real problem with this approach is that it is not 100% secure Anyone

can, from a blank document, use Insert | File and choose the protected

document to open it in an unprotected state, even if it has been password

protected

If the main concern is to restrict the user from accidentally working with the

file without the macros, then form field protection is certainly an acceptable

approach

Macros in Files Opened by Code

A related problem is macro security for other documents your code might need

to open If the user has set macro security to "Medium", a prompt appears if

any files opened by the code contain macros This can be irritating to the user if

¾ msoAutomationSecurityByUI Uses the security setting specified in the

Security dialog box

¾ msoAutomationSecurityForceDisable Disables all macros in all files opened

programmatically without showing any security alerts

¾ msoAutomationSecurityLow Enables all macros

This is the default value of the property This technique is used in Finding and Replacing in Multiple Documents on page 122

View the Appendix to learn how to store this procedure

Outlook Procedures

Out

Outlook Procedures

By Suat Ozgur

Most of the Outlook procedures do not have sample files because Outlook does

not store its procedures in files

Creating Control Buttons

This procedure automatically creates control buttons with VBA code

The following code shows how to create a custom control button in Outlook In

the example shown here, a custom button called “Create New Task” is created

Figure 70 – Creating a Custom Control Button

View the Appendix to learn how to store this procedure

in a Standard module

Option Explicit¶

' * * * * *¶

Public Sub CreateOutlookCommandBarButton()¶

'Remove the button if it is already existing¶

Call RemoveOutlookCommandBarButton¶

'Create new control button¶

'Temporary:=True : Available from now on¶

'Temporary:=False : Available only this Outlook session¶

With ActiveExplorer.CommandBars("Standard").Controls _¶

Add(msoControlButton, Temporary:=True)¶

'Caption to display on button¶

.Caption = "Create New Task"¶

'Procedure name to run when button is clicked¶

Outlook Procedures

Out

' * * * * *¶

Public Sub RemoveOutlookCommandBarButton()¶

'Error handler if control is not existing¶

'Continue if an error occurs¶

On Error Resume Next¶

'Remove custom control button¶

Public Sub CreateCommandBarButton()¶

'Remove the button if it is already existing¶

Call RemoveCommandBarButton¶

'Create new control button¶

'Temporary:=True : Available from now on¶

'Temporary:=False : Available only this session¶

With Application.CommandBars("Standard").Controls _¶

Add(msoControlButton, Temporary:=True)¶

'Caption to display on button¶

.Caption = "New Button"¶

'Procedure name to run when button is clicked¶

Public Sub RemoveCommandBarButton()¶

'Error handler if control is not existing¶

On Error Resume Next¶

'Remove custom control button¶

Application.CommandBars("Standard") _¶

Controls("New Button").Delete False¶

End Sub¶

Outlook Procedures

Out

Saving E-mail Attachments in a Specified Folder

This macro saves all e-mail attachments in the active Outlook folder into the

specified folder It automatically renames the saved files in the folder by

producing auto-incremented version numbers

View the Appendix to learn how to store this procedure

in a Standard module

Option Explicit¶

' * * * * *¶

Public Sub SaveAttachments()¶

'Outlook Application Objects declaration¶

Dim objApp As Outlook.Application¶

Dim objFolder As Outlook.MAPIFolder¶

Dim objItem As Object¶

Dim itemAttc As Outlook.Attachment¶

'FileSystemObject Objects declaration¶

Dim fso As Object 'FileSystemObject¶

Dim fld As Object 'Folder¶

Dim fil As Object 'File¶

Dim i As Long 'Counter¶

'Array variable to store file name and extension¶

Dim strFileName() As String¶

On Error GoTo ErrHandler¶

'Create FileSystemObject object¶

Set fso = CreateObject("Scripting.FileSystemObject")¶

Scenario: You sent out a questionnaire to 1,000 employees

in the company in the form of a Word document You

received all the responses back as Word document

attachments The attachments all have the same name You

know that this book provides code to extract data from Word

forms, but you can’t figure out how to quickly get all the

documents saved from the e-mails into a folder so you can

use that macro This entry solves your dilemma

'Set objApp object¶

Set objApp = Outlook.Application¶

'Set source folder as the currently activated folder¶

Set objFolder = objApp.ActiveExplorer.CurrentFolder¶

'Confirmation¶

If MsgBox("Do you want to extract all attached items " & _¶

"in " & objFolder.Name & _¶

" and save into " & fld.path & " directory?", _¶

vbYesNo + vbQuestion, "Confirmation") = vbNo _¶

Then GoTo ErrHandler¶

'Explore all mail items in selected folder¶

For Each objItem In objFolder.Items¶

'If item is mail object then continue processing item¶

If objItem.Class = olMail Then¶

'Explore all attachments in email message¶

For Each itemAttc In objItem.Attachments¶

'Increase counter for attachment count¶

i = i + 1¶

'Retrieve file name and extension¶

'Calls ExplodeFileName custom function¶

strFileName = ExplodeFileName(itemAttc.FileName)¶

'Create new file name if the same file is already¶

'existing in folder¶

'Simply adds _X at the end of the file¶

'X is the incrementing number¶

strFileName = CreateFileName(strFileName, fso, fld)¶

'Finally save attachment as file by given path¶

itemAttc.SaveAsFile fld.path & "\" & _¶

strFileName(0) & strFileName(1)¶

'Release object variables and memory¶

Set fso = Nothing¶

Set objApp = Nothing¶

Exit Sub¶

Outlook Procedures

Out

ErrHandler:¶

Select Case Err.Number¶

Case 76 'Target directory doesn't exist¶

MsgBox "Selected directory doesn't exist.", _¶

vbOKOnly + vbExclamation, "Error"¶

Case Is <> 0 'Another critical error¶

MsgBox Err.Number & "-" & Err.Description, _¶

vbOKOnly + vbExclamation, "Error"¶

Dim dotPos As Integer¶

Dim strArr(1) As String¶

'Find the last dot position to parse strFileName¶

'InStrRev function is being used to start from the¶

'Parse file name¶

strArr(0) = Left(strFileName, dotPos - 1)¶

'Parse file extension¶

strArr(1) = Right(strFileName, Len(strFileName) _¶

- dotPos + 1)¶

End If¶

'Return an array¶

'First item is the file name¶

'Second item is the file extension¶

ExplodeFileName = strArr¶

End Function¶

Outlook Procedures

Out

' * * * * *¶

Private Function CreateFileName(strFileName() As String, _¶

fso As Object, fld As Object)¶

'Variable declaration¶

Dim strSuffix As String¶

Dim intSuffix As Integer¶

Dim strFinalFileName(1) As String¶

'Increment intSuffix until file is not existing¶

'FileExists method returns True if there is a file named¶

'with parameter string¶

Do Until Not fso.FileExists(fld.path & "\" & _¶

strFileName(0) & strSuffix & strFileName(1))¶

intSuffix = intSuffix + 1¶

'Create file name suffix¶

strSuffix = "_" & CStr(intSuffix)¶

Loop¶

strFinalFileName(0) = strFileName(0) & strSuffix¶

strFinalFileName(1) = strFileName(1)¶

'Return an array¶

'First item is the final file name¶

'Second item is the file extension¶

CreateFileName = strFinalFileName¶

End Function¶

Note: The target folder in the SelectFolder function procedure should be set to the

desired path

Creating a Contacts Database

This macro creates an Access database file by using contacts information stored

in the Outlook Contacts folder If the database file already exists, then the user

is prompted to update it or recreate (overwrite) it

View the Appendix to learn how to store this procedure

in a Standard module

Scenario: Extracting information from the contacts in

Outlook is useful, even if it is for as simple a reason as to

have a backup of the information The Excel section showed

how to do this to an Excel spreadsheet Another option is to

save this information in an Access database

Outlook Procedures

Out

Option Explicit¶

' * * * * *¶

'Set database file name and table name¶

Const strFileName As String = "C:\MyContactsDatabase.mdb"¶

Const tblName As String = "tblContacts"¶

' * * * * *¶

Public Sub CreateContactsDatabase()¶

'Outlook Application Objects declaration¶

Dim objApp As Outlook.Application¶

Dim objNS As Outlook.NameSpace¶

Dim objFolder As Outlook.MAPIFolder¶

Dim objContact As Object¶

'Database file properties¶

Dim blnFileExists As Boolean¶

Dim objConn As Object¶

Dim objSchema As Object¶

Dim i As Integer 'Counter¶

On Error GoTo ErrHandler¶

'Verify if database file exists¶

If Dir(strFileName, vbNormal) <> "" Then¶

If MsgBox(strFileName & " is an existing file." & _¶

vbCrLf & "Do you want to update database?", _¶

vbYesNo + vbQuestion, _¶

"Update Database") = vbYes Then¶

'Use existing database to update¶

If Not blnFileExists Then¶

'Create database file¶

Call CreateNewAccessDatabase(strFileName)¶

End If¶

'Create database connection object¶

Set objConn = CreateObject("ADODB.Connection")¶

objConn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;" & _¶

"DATA SOURCE=" & strFileName & ";"¶

'Search for the table in database¶

'in case it already exists¶

'adSchemaTables = 20¶

Set objSchema = objConn.OpenSchema(20)¶

Do Until objSchema.EOF¶

If objSchema.Fields("TABLE_NAME") = tblName Then¶

'If table is found then skip CreateTable step¶

objSchema.Close¶

GoTo SaveContacts¶

End If¶

Outlook Procedures

Out

objSchema.MoveNext¶

Loop¶

'Table does not exist in database file¶

'Create new table¶

Call CreateTable(objConn)¶

SaveContacts:¶

'Set objApp object¶

Set objApp = Outlook.Application¶

'Set NameSpace object¶

Set objNS = objApp.GetNamespace("MAPI")¶

'Set source folder as default Contacts folder¶

Set objFolder = objNS.GetDefaultFolder(olFolderContacts)¶

'Save each contact as a new record in database table¶

For Each objContact In objFolder.Items¶

DoEvents¶

If objContact.Class = olContact Then¶

Call SaveData(objContact, objConn)¶

'Release object variables and free memory¶

Set objApp = Nothing¶

End Sub¶

' * * * * *¶

Private Sub CreateNewAccessDatabase(strFileName As String)¶

'ADODB Catalog Object declaration¶

Dim objDB As Object¶

'Database format¶

Dim intVer As Integer¶

'Create ADODB Catalog object¶

'to create a new database file¶

Set objDB = CreateObject("ADOX.Catalog")¶

intVer = 5 'Access 2000 database file format¶

'Create new database file¶

objDB.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _¶

"Jet OLEDB:Engine Type=" & intVer & _¶

";Data Source=" & strFileName¶

'Release object variables and free memory¶

Set objDB = Nothing¶

End Sub¶

Outlook Procedures

Out

' * * * * *¶

Private Sub CreateTable(objConn As Object)¶

'ADODB Command Object declaration¶

Dim objCmd As Object¶

'Create ADODB Command object to execute SQL command¶

Set objCmd = CreateObject("ADODB.Command")¶

'ADODB Command object needs to know the Connection¶

'object that it is working with¶

Set objCmd.ActiveConnection = objConn¶

'Create table by using Outlook Contact fields names¶

'Set SQL string to execute with ADODB Command object¶

objCmd.CommandText = "CREATE TABLE " & tblName & _¶

"([EntryID] STRING(255) PRIMARY KEY," & _¶

"[FullName] STRING(255)," & _¶

"[Email1Address] STRING(255)," & _¶

"[Email2Address] STRING(255)," & _¶

"[Email3Address] STRING(255)," & _¶

"[WebPage] STRING(255)," & _¶

"[BusinessPhone] STRING(255)," & _¶

"[BusinessFax] STRING(255)," & _¶

"[HomePhone] STRING(255)," & _¶

"[MobilePhone] STRING(255)," & _¶

"[PagerNumber] STRING(255)," & _¶

"[Address] STRING(255)," & _¶

"[AddressCity] STRING(255)," & _¶

"[AddressCountry] STRING(255)," & _¶

"[AddressPostalCode] STRING(255)," & _¶

"[AddressPostOfficeBox] STRING(255)," & _¶

"[AddressState] STRING(255)," & _¶

"[AddressStreet] STRING(255)," & _¶

"[Categories] STRING(255))"¶

'Execute ADODB Command object¶

'Similar to running a query in Access¶

'adCmdText = 1 to evaluate command text as SQL statement¶

objCmd.Execute , , 1¶

'Release object variables and free memory¶

Set objCmd = Nothing¶

End Sub¶

' * * * * *¶

Private Sub SaveData(objContact As Object, objConn As Object)¶

'ADODB Recordset Object declaration¶

Dim objRs As Object¶

'Create ADODB Recordset object¶

Set objRs = CreateObject("ADODB.Recordset")¶

'Open recordset by using SELECT statement of SQL¶

'in requested connection¶

objRs.Open "SELECT * " & _¶

"FROM " & tblName & _¶

" WHERE EntryID=" & Chr(34) & _¶

objContact.EntryID & Chr(34), objConn, 2, 3¶

With objRs¶