wordvbamoveleft 请教WORD的VBA高手

上面的代码来自eh论坛吧，是最早的不太完善的代码。

最大的缺点就是不能根据比例缩放。

也可以吧 mypic.Width = 200 '根据需要设置

mypic.Height = 150

值调整的小点

是的，比例我知道设置，如果设置为400.300就可以一张A4的纸张容纳2张照片，蛋我现在想让他容纳6张照片，把比例缩小之后，他只会在A4的左边有图片，右边是空白的，请问能解决不？

看看这个吧，让图片在表格中，如果不想显示表格，可以设置无框线颜色：

Sub 每行插入表格n个图()

On Error Resume Next

Application.ScreenUpdating = False

Dim D As FileDialog, a, P As InlineShape, t As Table

If Selection.Information(wdWithInTable) = True Then MsgBox "请将光标置于表格之外！": Exit Sub

With Application.FileDialog(msoFileDialogFilePicker)

.Title = "请选择..."

If .Show = -1 Then

n = InputBox("请输入表格的列数：", "列数", 3)

M = .SelectedItems.Count

Debug.Print "共有" & M & "个图片"; M

h = IIf(M / n = Int(M / n), 2 * M / n, 2 * (Int(M / n) + 1))

Set t = ActiveDocument.Tables.Add(Selection.Range, h, n)

t.Borders.Enable = True

t.Borders.OutsideLineStyle = wdLineStyleDouble

For Each a In .SelectedItems

B = Split(a, "\")(UBound(Split(a, "\")))

C = Split(B, ".")(0)

Set P = Selection.InlineShapes.AddPicture(FileName:=a, SaveWithDocument:=True)

With P

w = .Width

.Width = Int(410 / n)

.Height = .Width * .Height / w

End With

i = i + 1

Selection.MoveLeft wdCharacter, 1

Selection.MoveDown wdLine, 1

Selection.TypeText C

Selection.Cells(1).Select

Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter '决定了首行居中

Selection.HomeKey

Selection.MoveDown wdLine, -1

Selection.MoveRight wdCharacter, 2

Debug.Print i, n

If i = Val(n) Then

Selection.MoveRight wdCharacter, 1

Selection.Cells(1).Select

Selection.EndKey

Selection.MoveDown wdLine, 1

i = 0

End If

Next

End If

End With

Application.ScreenUpdating = True

End Sub

如何用VBA设置WORD文档的题目（即第一段）的格式

Sub宏1()
DimstrAsString,iAsInteger,jAsInteger
j=0
str=Application.ActiveDocument.Paragraphs(1).Range.Text
Fori=1ToLen(str)
IfMid(str,i,1)=""Then
Else
ExitFor
EndIf
j=j+1
Next
str=Right(str,Len(str)-j)
Application.ActiveDocument.Paragraphs(1).Range.Text=str
Application.ActiveDocument.Paragraphs(1).Range.Select
Selection.Font.Name="黑体"
Selection.Font.Size=18
Selection.Font.Bold=wdToggle
Selection.ParagraphFormat.Alignment=wdAlignParagraphCenter
EndSub
更多
高手！
能不能在您提供的代码后再加上正文设置代码？
正文（即第二段以后）格式：每段首行缩进2字符，字体为“仿宋-GB2312"，字号为“小三”，每段首行是：一 二三四五六七八九十或（一）（二）（三）（四）（五）（六）（七）（八）（九）（十）或1 2 3 4 5 6 7 8 9 10等字符要加粗
万分期待
Sub test()
With Application.ActiveDocument
Dim i, pcount As Integer, astr As String
pcount = .Paragraphs.Count
For i = 2 To pcount
astr = Left(.Paragraphs(i).Range.Text, 1)
Select Case astr
Case "1" To "9", "一", "二", "三", "四", "五", "六", "七", "八", "九", "十"
.Paragraphs(i).Range.Select
Selection.MoveLeft (1)
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Font.Bold = True
Case "（"
If Mid(.Paragraphs(i).Range.Text, 3, 1) = "）" Then
Select Case Mid(ActiveDocument.Paragraphs(i).Range.Text, 2, 1)
Case "一", "二", "三", "四", "五", "六", "七", "八", "九", "十"
.Paragraphs(i).Range.Select
Selection.MoveLeft (1)
Selection.MoveRight Unit:=wdCharacter, Count:=3, Extend:=wdExtend
Selection.Font.Bold = True
End Select
End If
End Select
Next
.Paragraphs(2).Range.Select
End With
With Selection
.MoveLeft (1)
.EndKey Unit:=wdStory, Extend:=wdExtend
.Font.Size = 15
.ParagraphFormat.CharacterUnitFirstLineIndent = 2
.Font.Name = "仿宋-GB2312"
End With
End Sub
您编写的题目格式代码与正文格式代码分开是可以用的，我需要把两段代码合在一起，敬请赐教，十分感谢
去 VBE 里面导入即可。
VBA如何遍历WORD文档中的某一级标题
使用Find方法，看看是不是快了。
'样式、符合样式的当前段文本
 Dim wdSty$, strTxt$
    wdSty = "标题 1"
    With Selection
        .HomeKey unit:=wdStory, Extend:=wdMove'光标移到文档首
        .Find.ClearFormatting
        .Find.Style = ActiveDocument.Styles(wdSty)'设置查找文本的样式为wdSty(“标题1”)
    End With
'循环查找文档里所有为“标题1”样式的段落，
    Do While Selection.Find.Execute(findtext:="*^13", MatchWildcards:=True, Format:=True)
        strTxt = Selection.Text '获取符合样式的文本
     '.......在这里录入处理代码
        Selection.Move unit:=wdWord, Count:=1
        If Selection.MoveRight <> 1 Then'文档尾退出
            Exit Do
        Else
            Selection.MoveLeft
        End If
    Loop
【Word VBA】反向继续查找下一处。
vba中用find方法。
range("a1:a10").find("lll",lookin:=xlvalues,lookat:=xlwhole,searchdirection:=2)
其中，lookin是指查找的信息类型；lookat是指查找的匹配度，xlWhole为精确查找，xlPart为模糊查找；SearchDirection是指的查找方向，xlnext或1为向下查找，xlprevious或2为向上查找。
上面那句就是在单元格A1:A10中反向精确查找lll的单元格，比如这中间有A3、A5和A8的值是lll，那首先找到的是A8单元格，FindPrevious向前查找，上一个是A5单元格，再上一个是A3单元格。
例表见附件，完整代码如下：
Sub反向查找()
SetRng=Range("a1:a10").Find("lll",LookIn:=xlValues,lookat:=xlWhole,searchdirection:=2)
IfNotRngIsNothingThen'判断有找到目标时
firstAddress=Rng.Address'先找到的单元格地址先记录下来
Do
MsgBox"找到了lll在"&Rng.Address&"！"'显示找到的lll的地址
SetRng=Range("a1:a10").FindPrevious(Rng)'向前查找下一个lll
LoopWhileNotRngIsNothingAndRng.Address<>firstAddress'当还能找到lll并且再找到的单元格地址不是初始单元格时
EndIf
EndSub
Sub正向查找()
SetRng=Range("a1:a10").Find("lll",LookIn:=xlValues,lookat:=xlWhole,searchdirection:=1)
IfNotRngIsNothingThen'判断有找到目标时
firstAddress=Rng.Address'先找到的单元格地址先记录下来
Do
MsgBox"找到了lll在"&Rng.Address&"！"'显示找到的lll的地址
SetRng=Range("a1:a10").FindNext(Rng)'向后查找下一个lll
LoopWhileNotRngIsNothingAndRng.Address<>firstAddress'当还能找到lll并且再找到的单元格地址不是初始单元格时
EndIf
EndSub
WORD VBA如何将首句字母变成大写？
Subtest()
DimstrAsString
str=ActiveDocument.Paragraphs(1).Range.Text'获取第1段内容
ActiveDocument.Paragraphs(1).Range.Text=str'设置第1段内容
ActiveDocument.Paragraphs(1).Range.Select
Selection.MoveLeft(1)'光标置于第1段段首
Selection.Delete(1)'从向右删除一个字符
Selection.TypeText("HelloWorld！")'从光标处插入字符串"HelloWorld！"
EndSub
vba word 输出TXT问题
用Write吧，为了避免多选一个回车，那就再加一句moveleft，最后改成
Selection.HomeKeyunit:=wdLine
Selection.MoveDownunit:=wdParagraph,Extend:=wdExtend
Selection.MoveLeftwdCharacter,1,wdExtend
Setfs=CreateObject("Scripting.FileSystemObject")
Setsr=fs.CreateTextFile("D:\"&TxtName&".txt",True)
sr.Write(Selection.Text)
sr.Close
word VBA中可否同时选中相同颜色的字和word VBA剪贴板程序
问题太多，还一分没有。
我有个小程序，自动将WINDOWS剪切板的内容读入WORD文件。你自己看看。
Public TempStr
Sub BeginCB()
MsgBox "只能选择纯文字！！！", vbInformation, "开始"
With Selection
    .EndKey unit:=wdStory
    .TypeText Text:=Chr(13) & Chr(13)
    .InsertDateTime DateTimeFormat:="yyyy-MM-dd", InsertAsField:=False, _
         DateLanguage:=wdSimplifiedChinese, CalendarType:=wdCalendarWestern, _
        InsertAsFullWidth:=False
    .MoveLeft unit:=wdCharacter, Count:=10, Extend:=wdExtend
    .Copy
    .EndKey unit:=wdStory
    .TypeText Text:=Chr(13)
End With
TempStr = Format(Now(), "yyyy-mm-dd")
Call FirOpen
End Sub
Function FirOpen()
Application.OnTime Now + TimeValue("00:00:01"), "CBText"
End Function
Sub CBText()
Dim MyData As DataObject
Set MyData = New DataObject
    MyData.GetFromClipboard
    getcbtext = MyData.GetText(1)
    If getcbtext <> TempStr Then
        Selection.TypeText Text:=getcbtext & Chr(13) & Chr(13)
        TempStr = getcbtext
    End If
Call FirOpen
End Sub
用VBA把Excel中的表粘贴到Word？
忘记说了，要加入word的Object library才行的。
方法：
在excel的vb编辑器菜单中，选“工具”---“引用”---在那列表中往下找“Microsoft Word 9.0 Object Library”，把它前面的框勾上，确定。
这样执行就没错了。
Sub Macro1() 
Dim appWD As Word.Application, doc As Object 
Range("A1:C3").Select 
Selection.Copy 
Set appWD = CreateObject("Word.Application") 
appWD.Visible = True 
Set appWD = GetObject(, "Word.Application") 
Set doc = GetObject("D:\doc1.doc") 
appWD.Visible = True 
With appWD.Selection.Find 
.Text = "指定位置" 
.Wrap = wdFindContinue 
End With 
appWD.Selection.Find.Execute 
appWD.Selection.MoveRight Unit:=wdCharacter, Count:=1 
appWD.Selection.TypeParagraph 
appWD.Selection.MoveLeft Unit:=wdCharacter, Count:=1 
appWD.Selection.PasteExcelTable False, False, False 
appWD.Quit (wdSaveChanges) 
End Sub
转载请注明出处51数据库 » wordvbamoveleft 请教WORD的VBA高手