上面的代码来自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:=wdLineSelection.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高手