word vba宏语言循环

Posted 2023-04-04

Sub 英文转公式()
'
' 英文转公式 宏
'
'
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^$"
.Replacement.Text = "β"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.OMaths.Add Range:=Selection.Range
End Sub

请大神帮忙把这变成循环的,可以搜索全文档
或者说你有写代码的液可以发给我吗

安装完整版的offiec2007不是精简版的，启动Word，选择“工具 → 宏 → 安全性”，将“安全级” 调到“最低”，再次打开word就可以。

　　Visual Basic for Applications（VBA）是Visual Basic的一种宏语言，是微软开发出来在其桌面应用程序中执行通用的自动化(OLE)任务的编程语言。主要能用来扩展Windows的应用程式功能，特别是Microsoft Office软件。也可说是一种应用程式视觉化的Basic 脚本。该语言于1993年由微软公司开发的的应用程序共享一种通用的自动化语言--------Visual Basic For Application(VBA)，实际上VBA是寄生于VB应用程序的版本。微软在1994年发行的Excel5.0版本中，即具备了VBA的宏功能。 参考技术A Sub 英文转公式()
'
' 英文转公式 宏
'
'
Selection.WholeStory'只要加上这一句就行了
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^$"
.Replacement.Text = "β"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.OMaths.Add Range:=Selection.Range
End Sub追问

不行啊,我要的是把word的英文都变成公式

追答

Sub 英文转公式()
'
' 英文转公式 宏
'
'
Selection.WholeStory'只要加上这一句就行了
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^$"
.Replacement.Text = "β"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub

追问

还是不行,或者你直接帮我做个代码出来吧,我可以再加点分

追答

文档附上来，然后写个说明吧

参考技术B 不知道有没有理解错你的意思，你指的是所有打开的文档么？
ct = Application.Documents.Count '获取已打开的所有文档
for i=1 to ct '用循环遍历所有文档

Application.Documents(i). activate
－－－－插入你的代码－－－－
next

另外Selection.Find.Execute改成
Selection.Find.Execute Replace:=wdReplaceAll
是替换本文档所有的关键字
Selection.Find.Execute Replace:=wdReplaceOne
这个是仅替换一个关键字

do
findtxt = mysel.Find.Execute(Replace:=wdReplaceOne)
loop while findtxt

这个循环是遍历本文档所有内容，逐一替换，如果未找到则退出追问

不是,是把一个文档的英文变成公式

追答

Selection.Find.ClearFormatting
With Selection.Find
.Text = "^$"
.Replacement.Text = "β"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
do
findtxt = Selection.Find.Execute(Replace:=wdReplaceOne)
if Not findtst then Selection.OMaths.Add Range:=Selection.Range
loop while findtxt

每循环一次，修改一个关键字，止至全部

追问

哪里有mysel 不明所以然

追答

没有。。。你把这段复制就可以了

参考技术C Selection.Find.Execute 把这句 改成：

Selection.Find.Execute Replace:=wdReplaceAll追问

这个会直接在英文的前面直接创建空白新公式,没有起到作用啊.

追答

英文替换成公式是什么意思， 刚才那句是换成 全部替换

追问

就是把一个文档里面的英文都转成公式

追答

Sub 英文转公式()
'
' 英文转公式 宏
'
'

Selection.Find.ClearFormatting
Do
With Selection.Find
.Text = "^$"
.Replacement.Text = "β"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.OMaths.Add Range:=Selection.Range
Loop Until Selection.Find.Found = False
End Sub

本回答被提问者采纳

Word 宏 VBA：使图像适合形状

【中文标题】Word 宏 VBA：使图像适合形状

【英文标题】：Word macro VBA: Fit the image to the shape

【发布时间】：2022-01-15 05:23:37

【问题描述】：

我想让图像适合形状。代码很简单：

Function CmPt(cm As Single) As Single
' Convert centimeters to points.

    CmPt = Application.CentimetersToPoints(cm)
End Function

Sub InsertCanvas()
' Insert puzzle image canvas to the document.

    Dim edge As Single
    edge = CmPt(4)

    Dim canvas As Shape
    Set canvas = ActiveDocument.Shapes.AddShape(Type:=msoShapeRectangle, Left:=CmPt(2.5), Top:=CmPt(2.5), Width:=edge, Height:=edge, Anchor:=Selection.Paragraphs(1).Range)
    
    Dim image_path As String
    image_path = ActiveDocument.Path & Application.PathSeparator & "images" & Application.PathSeparator & "image.jpeg"

    With canvas
        .Line.Weight = 1
        .Line.ForeColor.RGB = RGB(64, 64, 64)
    
        .Fill.Visible = msoTrue
        .Fill.BackColor.RGB = RGB(255, 255, 255)
        .Fill.UserPicture image_path
  End With
End Sub

但是现在，图像填满了正方形。我想适合图像。我知道 Word 可以做到，但我相信我必须根据原始纵横比计算自己。是否可以获得.UserPicture 的原始大小？或者是否可以在不将图像插入文档的情况下获取硬盘驱动器上任何图片的宽度和高度？谢谢

【问题讨论】：

你只需要图片尺寸吗？上面的代码将图片拉伸到形状容器尺寸。我可以告诉你如何提取尺寸（以像素为单位）

您的问题并不完全清楚，但我认为您想要的是将图片添加到形状中，如果图片的纵横比不同，则在较小的边上会出现深灰色条带.这是不可能的。形状可以有颜色填充或图像填充，不能同时有。

Timothy Rylatt 这是可能的。但这不是问题所在。问题是关于原始图像大小以计算纵横比。 @FaneDuru 这正是我想要的。如何获取图片的原始尺寸？

@Timothy Rylatt 哦，对不起，现在我明白你说的是什么了。我不知道您是否正确，但是可以通过某些（可能是默认的）背景来实现您描述的行为。也许你是对的，不可能将背景颜色与图像一起设置，但可以更改链接图像的尺寸以保持原始纵横比。

请编辑您的问题并描述您尝试复制的 UI 功能。 VBA 对象模型不包括 UI 的所有功能，因此可能没有直接的等价物，您需要考虑解决方法，例如将图像放入固定大小的单个单元格表中。

【参考方案1】：

请尝试下一个功能。它将提取图像尺寸而不以任何方式导入：

Function ImgDimensions(ByVal sFile As String) As Variant
    Dim oShell  As Object, oFolder As Object, oFile As Object, arr
    Dim sPath As String, sFilename As String, strDim As String
 
    sPath = Left(sFile, InStrRev(sFile, "\") - 1)
    sFilename = Right(sFile, Len(sFile) - InStrRev(sFile, "\"))
 
    Set oShell = CreateObject("Shell.Application")
    Set oFolder = oShell.Namespace(CStr(sPath))
    Set oFile = oFolder.ParseName(sFilename)
 
    strDim = oFile.ExtendedProperty("Dimensions")
    strDim = Mid(strDim, 2): strDim = Left(strDim, Len(strDim) - 1)
    arr = Split(strDim, " x ")
    ImgDimensions = Array(CLng(arr(0)), CLng(arr(1)))
End Function

它可能会替换上面代码中的导入行，以及picture 声明：

   Set picture = ActiveDocument.Shapes.AddPicture(image_path, LinkToFile:=False, SaveWithDocument:=True)
    width = picture.width
    height = picture.height
    picture.Delete

与：

   Dim arr
   arr = ImgDimensions(sFile)
   width = arr(0): height = arr(1)

【参考方案2】：

我找到了适合我的解决方案。我知道它并不理想，我不能说我喜欢它，但它已经足够了，它工作正常。我在这里只发布一个sn-p：

Dim width As Long
Dim height As Long

Set picture = ActiveDocument.Shapes.AddPicture(image_path, LinkToFile:=False, SaveWithDocument:=True)
width = picture.width
height = picture.height
picture.Delete

编辑： Word宏的完整vba代码

Function CmPt(cm As Single) As Single
' Convert centimeters to points.

    CmPt = Application.CentimetersToPoints(cm)
End Function

Sub InsertPuzzleCard()
' Insert puzzle card to the document.

    Dim edge As Single
    edge = CmPt(4)

    Dim canvas As Shape
    Set canvas = ActiveDocument.Shapes.AddShape(Type:=msoShapeRectangle, Left:=CmPt(2.5), Top:=CmPt(2.5), width:=edge, height:=edge, Anchor:=Selection.Paragraphs(1).Range)
    
    Dim image_path As String
    image_path = ActiveDocument.Path & Application.PathSeparator & "images" & Application.PathSeparator & "image.jpeg"
                                                                               
    Dim picture As Shape
    Dim width As Long
    Dim height As Long
    Dim ratio As Single
    Dim new_width As Long
    Dim new_height As Long
    
    Set picture = ActiveDocument.Shapes.AddPicture(image_path, LinkToFile:=False, SaveWithDocument:=True)
    width = picture.width
    height = picture.height
    picture.Delete
    
    ratio = width / height
    If ratio < 1 Then
        new_width = width * edge / height
        new_height = edge
    Else
        new_width = edge
        new_height = height * edge / width
    End If
    

    With canvas
        .Line.Weight = 1
        .Line.ForeColor.RGB = RGB(64, 64, 64)
    
        .Fill.Visible = msoTrue
        .Fill.UserPicture image_path
        
        .PictureFormat.Crop.PictureWidth = new_width
        .PictureFormat.Crop.PictureHeight = new_height
  End With
End Sub