[原创并分享]图片编辑器

为进一步扩大WORD中各个领域的应用以及提高网友们对WORD二次开发的兴趣，及楼主的要求，现将该图片编辑器代码公布。

适宜范围：

对于大量图片的编辑，设置比较统一的图（照）片格式（可任意设置），并配置相关的说明性文字和统一编号（可任意设置），在同一页面中做到类似于即点即输入功能的图片编辑程序。

关于照片编辑的操作方法与说明：

功能与用途：指定光标处插入指定的图片，并能统一和分批编号。

必须：将工具/宏/安全性级别设置为低，假如不为低，请设置为低后退出并重启WORD。

必须：将工具/选项/编辑选项卡中的插入/粘贴图片的方式调整为四周型，否则将不能调整图片大小；

注意：每次开启该文档时，先运行“指定高宽”命令，如果没有设置，当点击“插入照片”时，会自动出现设置高宽对话框（相当于调用该“指定高宽”命令）

提示：当每次需要相同尺寸的照片时，无须再进行“指定高宽”和"名称"的设置，程序会自动记忆；只有需要设置不同尺寸时，再行设置高宽或名称.

提示：插入/图片/来自文件命令同新菜单（帮助菜单）右侧新菜单（照片编辑/光标处插入照片）命令和右键菜单/光标处插入照片命令等同，但应先定位，再点击任一命令。

注意：高度和宽度的度量单位为厘米，先高度再宽度，输入对话框中的输入数据形式如：“4*5”，或者“5.26*3.17”等，必须用“*”（星号）作为分隔符，小数点应该使用英文状态下的标点符号，代码程序不支持无效数据的输入。（有提示）。

操作方法：先定位，即在需要插入照片的页面位置，双击鼠标，使光标处于即点即输入位置，然后右击，在右键快捷菜单中出现：“光标处插入照片”，点击该命令，即可在此处进行指定照片的插入。

编号与照片已进行了组合，除非特殊需要，可以取消组合。在组合的情况下，编号栏文本框中可直接进行编辑。

设置高宽和名称:每次需要改变原来的照片尺寸和名称,可通过此命令进行操作.可将照片的编号重新设置为指定的开始编号，注意此数据即使文档退出（保存）后，下次仍然有效。假如用户上次编辑到“照片10”，则重新开启文档后将自动从11开始编号。

错误重启:受不可预知因素影响,可能使插入照片的位置处于非正常状态(位于页面左上角时,您需要使用该命令.

由于版本不同以及本程序代码的更新，《关于照片编辑的操作方法与说明》中的一些内容也许不完全适合，但其原理相通，恕不再另行更新。

相关链接：http://club.excelhome.net/viewthread.php?tid=67128&extra=&page=2

IfkuZULO.rar (62.57 KB, 下载次数: 559)

VBA工程密码为“shourou"

以下为代码供参考：

'在关闭文档时恢复右键菜单

Private Sub Document_Close()

On Error Resume Next

Application.CommandBars("text").Controls("光标处插入照片").Delete

End Sub

'***********************************

'打开时修改右键菜单

Private Sub Document_Open()

Dim NewButton As CommandBarButton

Call ErrReset

On Error Resume Next

Set NewButton = Application.CommandBars("text").Controls.Add(Type:=msoControlButton)

With NewButton

.Caption = "光标处插入照片"

.OnAction = "InsertPicture"

.FaceId = 100

.Visible = True

End With

End Sub

'***********************************

'这是一个右键恢复代码(还原)

Sub ResetControls()

Application.CommandBars("text").Reset

End Sub

'***********************************

'以下为声明为类模块

Public WithEvents App As Word.Application

'***********************************

'在右键事件中获得当前光标处的坐标位置

Private Sub App_WindowBeforeRightClick(ByVal Sel As Selection, Cancel As Boolean)

SLT = Sel.Information(wdHorizontalPositionRelativeToPage)

STP = Sel.Information(wdVerticalPositionRelativeToPage)

End Sub

'在选定照片过程中进行返回图片属性的代码

Private Sub App_WindowSelectionChange(ByVal Sel As Selection)

Dim SelShape As Shape, W As Single, H As Single, Hp As Single, Ht As Single

On Error Resume Next

If Selection.Type = wdSelectionShape Then

If Sel.ShapeRange.Type = 6 And Sel.ShapeRange.Count = 1 Then

Set SelShape = Sel.ShapeRange(1)

With SelShape

W = Round(PointsToCentimeters(.Width), 2)

H = Round(PointsToCentimeters(.Height), 2)

Hp = H - Round(PointsToCentimeters(25), 2)

Ht = Round(PointsToCentimeters(25), 2)

End With

Application.StatusBar = "照片宽:" & W & "厘米," & "高:" & Hp & "厘米;文本框高:0" _

& Ht & "厘米;图片总高:" & H & "厘米"

End If

End If

End Sub

'***********************************

'续上页

'以下为模块中进行相关人机对话然后在当前光标处插入图片

Public SLT As Single, STP As Single, PH As Single, PW As Single, PicName As String

Sub InsertPicture()

Dim Mydialog As FileDialog, MyPicture As Shape, MyText As Shape

Dim PL As Single, PT As Single, Pcount As Integer, strBmp As String

On Error Resume Next

Application.ScreenUpdating = False

If SLT = -1 Or STP = -1 Or Selection.Type <> wdSelectionIP _

Then MsgBox "请将光标定位于页面中或者错误的光标选定项目", vbOKOnly + vbCritical, "Microsoft Word": Exit Sub

' MsgBox SLT & STP

If PH * PW = 0 Then SetHW

PicName = ActiveDocument.Variables("PicName").Value

Set Mydialog = Application.FileDialog(msoFileDialogOpen)

With Mydialog

.Filters.Clear

.Filters.Add "Images", "*.Bmp; *.Gif; *.Jpg; *.Jpeg", 1

.AllowMultiSelect = False

If .Show = -1 Then

strBmp = .SelectedItems(1)

Else

Exit Sub

End If

With ActiveDocument

Pcount = .Variables("Pcount").Value

Pcount = Pcount + 1

.Variables("Pcount").Value = Pcount

Set MyPicture = .Shapes.AddPicture(FileName:=strBmp, _

Left:=SLT, Top:=STP, Width:=PW, Height:=PH)

With MyPicture

.Name = "Pone" & Pcount

.LockAnchor = False

.WrapFormat.Side = wdWrapBoth

End With

Set MyText = .Shapes.AddTextbox(msoTextOrientationHorizontal, SLT, STP + PH, PW, 25)

With MyText

.Name = "Ptwo" & Pcount

.Line.Visible = msoFalse

.TextFrame.TextRange.Text = PicName & Pcount

.TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphCenter

End With

.Shapes.Range(Array("Pone" & Pcount, "Ptwo" & Pcount)).Group.Name = "Pthree" & Pcount

.Shapes("Pthree" & Pcount).WrapFormat.AllowOverlap = False

End With

End With

Application.ScreenUpdating = True

End Sub

'***********************************

'打开窗体

Sub SetHW()

UserForm1.Show

End Sub

'***********************************

'重新定义编号等

Sub SetRestore()

Dim Y As String

Y = InputBox("请在此输入重新开始的编号值", "Microsoft Word 编号重置")

If Y = "" Then

ActiveDocument.Variables("Pcount").Value = 0

Else

ActiveDocument.Variables("Pcount").Value = CInt(Y) - 1

End If

End Sub

'***********************************

'将初始值写入文档变量中,相当于初始化文档变量

Sub test()

ActiveDocument.Variables.Add Name:="Pcount", Value:=0

ActiveDocument.Variables.Add Name:="PicName", Value:="照片"

End Sub

'***********************************

'观测文档变量值的变化

Sub GetTest()

MsgBox ActiveDocument.Variables(1)

MsgBox ActiveDocument.Variables(2)

End Sub

'***********************************

'当发生错误后类模块可能被终止,通过此代码重新触发类模块进程

Sub ErrReset()

Register_Event_Handler

End Sub

'***********************************

'接续上页:

'进行类模块的初始化(放在模块2中)

Dim X As New EventClassModule

Sub Register_Event_Handler()

Set X.App = Word.Application

End Sub

'***********************************

'此为窗体中的代码

Private Sub CommandButton1_Click()

Dim MyValue As String, L As Byte

On Error GoTo Errhandle

MyValue = Me.TextBox1

If MyValue = "" Then Exit Sub

L = InStr(MyValue, "*")

If L = 0 Then

GoTo Errhandle

Else

PH = CentimetersToPoints(CSng(Mid(MyValue, 1, L - 1)))

PW = CentimetersToPoints(CSng(Mid(MyValue, L + 1, Len(MyValue) - L)))

End If

PicName = Me.TextBox2

If PicName <> "" Then

ActiveDocument.Variables("PicName").Value = PicName

Else

PicName = ActiveDocument.Variables("PicName").Value

End If

Me.Hide

Exit Sub

Errhandle:

MsgBox "无效数据,请重新正确输入!", vbOKOnly + vbInformation

If PH * PW <> 0 Then

Me.TextBox1 = PointsToCentimeters(PH) & "*" & PointsToCentimeters(PW)

Else

Me.TextBox1 = "2*3"

End If

Me.TextBox1.SetFocus

End Sub

Private Sub UserForm_Initialize()

Me.Caption = "Microsoft Word 照片尺寸/名称设置"

If PH * PW <> 0 Then

Me.TextBox1 = PointsToCentimeters(PH) & "*" & PointsToCentimeters(PW)

Else

Me.TextBox1 = "2*3"

End If

Me.TextBox2 = ActiveDocument.Variables("PicName")

Me.TextBox1.SetFocus

Me.CommandButton1.Default = True

End Sub

请窦兄帮着逐语句调试一下，哪儿有问题，我好对症下药。（PW：shourou)

做为论坛一员，特别是对WORD有所偏爱的一员，对守柔的研究，只能是击节叫好。

送朵花。

守柔做出来的东东当然是好东东，支持支持！

如果让我来做楼主的东东，因为不会VBA，所以我只能先用做相册的方式将大量图片一次性插入PPT里，然后再发送到WORD里，但那样只能部分减少插入图片和调整图片的步骤，仍然需要进行一些调整和插入题注，而且楼主的要求好麻烦哦，我想也只有守柔才能搞的定哦。

守柔，我强烈支持你！

挺好，运行没有错误。

不过每次插入的图片并没有在光标的位置上，在光标偏下二行的位置。

另外，图片注释的位置是否应该可选，更方便一些。