如何使用VBA对word、excel、ppt的首页首行左侧批量添加文字

对于一份简单的Word文档，基本的查找VBA可以像下面这样实现：

Dim hasFound ' 定义是否找到

Selection.WholeStory

With Selection.Find

.ClearFormatting

.MatchWholeWord = False

.MatchCase = False

hasFound = .Execute("要查找的文字")

End With

转化为VBScript代码也很容易，多个创建Word.Application并打开Word文件的过程。

下面定义FileFinder接口，当然VBS没有接口的概念，我们只是象征式的说明下：

Interface FileFinder

Function isTextExists(search, filename)

End Function

End Interface

只需要实现一个方法接口，那就是isTextExists，判断要搜索的文本是否存在于指定的文件中。下面给出关于Word查找的VBS脚本代码实现：

Class DocumentsFinder

Private vbaObject

Private Application

Private Sub Class_Initialize()

Set vbaObject = WSH.CreateObject("Word.Application")

vbaObject.Visible = False

End Sub

Private Sub Class_Terminate()

vbaObject.Visible = True

vbaObject.Quit

Set vbaObject = Nothing

End Sub

Private Function SearchStringInSingleDocument(str, doc)

Dim Selection

Set Selection = vbaObject.Selection

Selection.WholeStory

With Selection.Find

.ClearFormatting

.MatchWholeWord = False

.MatchCase = False

SearchStringInSingleDocument =.Execute(str)

End With

Set Selection = Nothing

End Function

Public Function isTextExists(str, filename)

On Error Resume Next

Dim doc

Set doc = vbaObject.Documents.Open(filename)

isTextExists = SearchStringInSingleDocument(str, doc)

doc.Close

Set doc = Nothing

If Err Then Err.Clear

End Function

End Class

其中调用了Documents.Open打开一个Word文档，然后再通过SearchStringInSingleDocument方法来搜索指定文档的文字，这个方法就是刚才讲解的VBA宏的实现。

用vba在word中插入一个文本框：

ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 120#, 27#, 72#, 63#).Select

四个 数字是坐标

VBA没怎么研究，帮你找了个资料，是别人写的。希望对你有帮助。

----------------------------------------------------------

前两天刚刚看过一个不需要outlook发邮件的方法，转贴在下面；

我用access试过是可以的，excel中应该也没有问题，哪位高人给大家做个例子？

:handshake

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Private Sub 发送_Click()

On Error GoTo Err1

If Len(Nz(Me.发件人用户名)) = 0 Or Len(Nz(Me.发送邮箱)) = 0 Or Len(Nz(Me.发件人密码)) = 0 _

Or Len(Nz(Me.收件人用户名)) = 0 Or Len(Nz(Me.接收邮箱)) = 0 Or Len(Nz(Me.主题)) = 0 Then

MsgBox "输入信息不完全!" &Chr(13) &Chr(13) &_

"发件人用户名、邮箱、密码，收件人用户名、邮箱，主题等均要输入。", vbInformation, "提示"

Exit Sub

End If

Dim stUl As String '微软服务器网址

Dim vCDO As Variant 'CDO.Message对象

Dim stUs As String '发送方邮箱名称

Dim stRx As String '发送方邮箱服务器

Dim stPw As String '发送方邮箱密码

Dim stE1 As String '主要接收方邮箱完整帐号

Dim stE2 As String '备用接收方邮箱完整帐号

Dim stZt As String '邮件主题

Dim stNr As String '邮件内容

Dim stFj As String '邮件附件

stUs = Trim(Me.发件人用户名)

stRx = Trim(Me.发送邮箱)

stPw = Trim(Me.发件人密码)

stE1 = Trim(Me.收件人用户名) &"@" &Trim(Me.接收邮箱)

stZt = Trim(Me.主题)

stNr = Trim(Nz(Me.内容))

stFj = Trim(Nz(Me.附件))

stUl = "http://schemas.microsoft.com/cdo/configuration/" '微软服务器网址

DoCmd.Hourglass True

Me.Label21.Visible = True

Set vCDO = CreateObject("CDO.Message") '建立对象

vCDO.From = stUs &"@" &stRx'发送方邮箱完整帐号

vCDO.To = stE1 '主要接收方邮箱完整帐号

If Len(stE2) >0 Then vCDO.CC = stE2 '备用接收方邮箱完整帐号

vCDO.SubJect = stZt '邮件主题

vCDO.Textbody = stNr '邮件内容

If Len(stFj) >0 Then vCDO.AddAttachment stFj'邮件附件

With vCDO.Configuration.Fields

.Item(stUl &"smtpserver") = "smtp." &stRx 'SMTP服务器地址

.Item(stUl &"smtpserverport") = 25 'SMTP服务器端口

.Item(stUl &"sendusing") = 2'发送端口

.Item(stUl &"smtpauthenticate") = 1 '

.Item(stUl &"sendusername") = stUs '发送方邮箱名称

.Item(stUl &"sendpassword") = stPw '发送方邮箱密码

.Update

End With

vCDO.Send'发送

Set vCDO = Nothing

MsgBox "发送成功！", vbInformation, "提示"

Exit1:

Me.Label21.Visible = False

DoCmd.Hourglass False

Exit Sub

Err1:

MsgBox Err.Description, vbExclamation, "错误提示"

Resume Exit1

End Sub

Private Sub 关闭_Click()

DoCmd.Close

End Sub

Private Sub 选择附件_Click()

Dim dlgOpen ' As FileDialog

Set dlgOpen = FileDialog(1)

With dlgOpen

.Show

.AllowMultiSelect = False

If .SelectedItems.Count >0 Then Me.附件 = .SelectedItems(1)

End With

End Sub

---