[第9期]图片顺移

守柔

Word9竞赛题说明：

单数行总是图片。

奇数行总是文字说明，文字说明并非总是来自图片名，可以是用户任意说明性文字。

要求:

利用编程方法，将图片插入在所选单元格内，原有图片向右向下顺移，但不增加表格中的单元格。比如，选中KEVIN图片所在单元格，插入图片时，新的图片替换现有图片，但KEVIN现有图片和文字说明一起移动下第三行和第四行的首列，apolloh、七叶一枝梅、布衣铁剑分别右移一个单元格。

当所有图片填满奇数行单元格时，再次插入图片时无效。

[em04]:示例中借各位的"人头"一用,如有不妥,请原谅.[em05]

[此贴子已经被apolloh于2006-5-2 8:48:13编辑过]

qee用

(本来只想上传附件的,不知为什么出现40字节错误)
'************************************************************
'* 守柔版主,以下是三个Sub的功能:
'* Sub LinkCommand: 将功能关联到WORD的"插入图片(来自文件)"
'* Sub ResetCommand:恢复WORD原有功能
'* Sub MyInsertPict:主功能
'************************************************************
Option Explicit
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Sub LinkCommand()
Dim cm As CommandBarControl
For Each cm In Application.CommandBars.FindControls(ID:=2619)
cm.OnAction = "MyInsertPict"
Next cm
End Sub
Sub ResetCommand()
Dim cm As CommandBarControl
For Each cm In Application.CommandBars.FindControls(ID:=2619)
cm.OnAction = ""
Next cm
End Sub
Sub MyInsertPict()
Dim i%, j%, k%
Dim TB As Table, tbRows%, tbColumns%, tbRow%, tbColumn%
Dim filDlg As FileDialog, fnm$
'判断当前光标位置是否在表格中,并且只选择了一个方格
If Not Selection.Information(wdWithInTable) Then
MsgBox "请在表格中选择插入图片的位置!"
Exit Sub
End If
If Selection.Range.Cells.Count <> 1 Then
MsgBox "请选择一个方格作为插入图片的位置!"
Exit Sub
End If
'取当前表有关参数,以备操作
Set TB = Selection.Tables(1)
tbRows = TB.Rows.Count
tbColumns = TB.Columns.Count
tbRow = Selection.Cells(1).Row.Index
If tbRow Mod 2 = 0 Then tbRow = tbRow - 1
tbColumn = Selection.Cells(1).Column.Index
'选择插入的图片(来自文件)
Set filDlg = Application.FileDialog(msoFileDialogOpen)
With filDlg
.AllowMultiSelect = False
.Title = "插入图片"
'.InitialFileName = ThisDocument.Path & "\Wdpic"
.Filters.Clear
.Filters.Add Description:="图片文件", Extensions:="*.jpg,*.jpeg,*.bmp,*.gif,*.ico"
.Filters.Add Description:="所有文件", Extensions:="*.*"
If Not .Show Then Exit Sub
fnm = .SelectedItems(1)
End With
'如果选定位置为空,直接转到插入图片
If TB.Cell(tbRow, tbColumn).Range.InlineShapes.Count = 0 Then GoTo InsPic
'如果选定位置不为空,判断表是否还有空格可插入图片
If TB.Cell(tbRows - 1, tbColumns).Range.InlineShapes.Count > 0 Then
MsgBox "表格已满,无法插入新图片!"
Exit Sub
End If
'--插入位置原有图片后移
For i = tbRows - 1 To tbRow Step -2
If i = tbRow Then
If tbColumns - tbColumn < 1 Then Exit For
TB.Cell(tbRow, tbColumn).Range.Select
Selection.EndKey Unit:=wdLine
Selection.MoveRight Unit:=wdCharacter, Count:=tbColumns - tbColumn, Extend:=wdExtend
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Cut
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Paste
Exit For
End If
TB.Cell(i, 1).Range.Select
Selection.EndKey Unit:=wdLine
Selection.MoveRight Unit:=wdCharacter, Count:=4, Extend:=wdExtend
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Cut
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Paste
TB.Cell(i - 2, tbColumns).Select
Selection.EndKey Unit:=wdLine
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Cut
TB.Cell(i, 1).Select
Selection.EndKey Unit:=wdLine
Selection.Paste
Next i
InsPic:
'插入选定的图片(来自文件)
TB.Cell(tbRow, tbColumn).Range.InlineShapes.AddPicture FileName:=fnm
If Len(TB.Cell(tbRow + 1, tbColumn).Range.Text) = 2 Then
i = InStrRev(fnm, "\")
j = InStrRev(fnm, ".")
If j < i Then j = i + 10
fnm = Mid(fnm, i + 1, j - i - 1)
TB.Cell(tbRow + 1, tbColumn).Range.Text = fnm
End If
OpenClipboard (0)
EmptyClipboard
CloseClipboard
End Sub

sailorgg

我的解法：

Public YesorNoKK As Boolean

Sub main()
Dim Pname As String
Dim Ntemp As String
Dim Narray
Dim Adg As Integer, InsetregS As Integer
Dim my1 As Boolean, my2 As Boolean
Dim r As Integer, c As Integer
Dim a As Integer, b As Integer
Dim Mnum As Integer
Dim Myr1 As Integer, Myr2 As Integer, Myc1 As Integer, Myc2 As Integer, PSc As Integer
Application.ScreenUpdating = False
YesorNoKK = True
IfKK
If YesorNoKK = False Then Exit Sub
Selection.HomeKey Unit:=wdLine
With Application.Dialogs(wdDialogInsertPicture)
Adg = .Show
Ntemp = .Name
End With
If Adg <> -1 Then Exit Sub
Narray = VBA.Split(Ntemp, "\", -1)
Pname = VBA.Left(Narray(UBound(Narray)), VBA.Len(Narray(UBound(Narray))) - 4)
'循环查找插入图片所在单元格
my1 = True
my2 = True
For r = 1 To 4
If r = 1 Or r = 3 Then
For c = 1 To 5
a = Me.Tables(1).Rows(r).Cells(c).Range.End
b = Me.Tables(1).Rows(r).Cells(c).Range.Start
If a - b > 2 And my1 = True Then Myr1 = r: Myc1 = c: my1 = False
If a - b = 1 And my2 = True And my1 = False Then Myr2 = r: Myc2 = c: my2 = False
If my1 = False And my2 = True Then Mnum = Mnum + 1
Next
End If
Next
If my2 = True Then MsgBox "单元格已满或者在插入点前有空单元格，无法插入图片": Me.Undo 1: Exit Sub
With Me.Tables(1)
PSc = Myc1
For r = Me.Tables(1).Range.InlineShapes.Count To Me.Tables(1).Range.InlineShapes.Count - Mnum - 1 Step -1
If Myr2 = 3 And Myc2 <> 1 Then
Me.Tables(1).Rows(Myr2).Cells(Myc2 - 1).Range.Cut
Me.Tables(1).Rows(Myr2).Cells(Myc2).Range.Paste
Me.Tables(1).Rows(Myr2 + 1).Cells(Myc2 - 1).Range.Cut
Me.Tables(1).Rows(Myr2 + 1).Cells(Myc2).Range.Paste
End If
If Myr2 = 3 And Myc2 = 1 Then
Me.Tables(1).Rows(1).Cells(5).Range.Cut
Me.Tables(1).Rows(3).Cells(1).Range.Paste
Me.Tables(1).Rows(2).Cells(5).Range.Cut
Me.Tables(1).Rows(4).Cells(1).Range.Paste
End If
If Myr2 = 1 Then
Me.Tables(1).Rows(1).Cells(Myc2 - 1).Range.Cut
Me.Tables(1).Rows(1).Cells(Myc2).Range.Paste
Me.Tables(1).Rows(2).Cells(Myc2 - 1).Range.Cut
Me.Tables(1).Rows(2).Cells(Myc2).Range.Paste
End If

If Myc2 >= 1 Then Myc2 = Myc2 - 1
If Myc2 = 0 And Myr2 > 2 Then Myr2 = Myr2 - 2: Myc2 = 5
If Myr2 = 1 And Myc2 = PSc Then Exit For
Me.UndoClear
Next
'Debug.Print Myr2 & " " & Myc2
Addname = InputBox("请为插入的图片写上说明文字", "请输入", Pname)
Me.Tables(1).Rows(Myr1 + 1).Cells(Myc1).Range.Text = Addname
InsetregS = Me.Tables(1).Cell(Myr1, Myc1 + 1).Range.Start
Me.Range(InsetregS, InsetregS + 1).Cut
Me.Range(InsetregS - 1, InsetregS).Paste
Application.ScreenUpdating = True
End With
End Sub
Sub IfKK()
'将光标下移一个单元格
Selection.EndKey Unit:=wdLine
Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
If VBA.Len(Selection.Range.Text) = 0 Then
With Application.Dialogs(wdDialogInsertPicture)
Adg = .Show
Ntemp = .Name
End With
End If
If Adg <> -1 Then Exit Sub
Narray = VBA.Split(Ntemp, "\", -1)
Pname = VBA.Left(Narray(UBound(Narray)), VBA.Len(Narray(UBound(Narray))) - 4)
Selection.MoveDown Unit:=wdLine, Count:=1
Addname = InputBox("请为插入的图片写上说明文字", "请输入", Pname)
Selection.InsertAfter Addname
YesorNoKK = False
Application.ScreenUpdating = False
End Sub

rongjun

lkyzhs

(本来只想上传附件的,不知为什么出现40字节错误)
'************************************************************
'* 守柔版主,以下是三个Sub的功能:
'* Sub LinkCommand: 将功能关联到WORD的"插入图片(来自文件)"
'* Sub ResetCommand:恢复WORD原有功能
'* Sub MyInsertPict:主功能
'************************************************************
Option Explicit
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Sub LinkCommand()
Dim cm As CommandBarControl
For Each cm In Application.CommandBars.FindControls(ID:=2619)
cm.OnAction = "MyInsertPict"
Next cm
End Sub
Sub ResetCommand()
Dim cm As CommandBarControl
For Each cm In Application.CommandBars.FindControls(ID:=2619)
cm.OnAction = ""
Next cm
End Sub
Sub MyInsertPict()
Dim i%, j%, k%
Dim TB As Table, tbRows%, tbColumns%, tbRow%, tbColumn%
Dim filDlg As FileDialog, fnm$
'判断当前光标位置是否在表格中,并且只选择了一个方格
If Not Selection.Information(wdWithInTable) Then
MsgBox "请在表格中选择插入图片的位置!"
Exit Sub
End If
If Selection.Range.Cells.Count <> 1 Then
MsgBox "请选择一个方格作为插入图片的位置!"
Exit Sub
End If
'取当前表有关参数,以备操作
Set TB = Selection.Tables(1)
tbRows = TB.Rows.Count
tbColumns = TB.Columns.Count
tbRow = Selection.Cells(1).Row.Index
If tbRow Mod 2 = 0 Then tbRow = tbRow - 1
tbColumn = Selection.Cells(1).Column.Index
'选择插入的图片(来自文件)
Set filDlg = Application.FileDialog(msoFileDialogOpen)
With filDlg
.AllowMultiSelect = False
.Title = "插入图片"
'.InitialFileName = ThisDocument.Path & "\Wdpic"
.Filters.Clear
.Filters.Add Description:="图片文件", Extensions:="*.jpg,*.jpeg,*.bmp,*.gif,*.ico"
.Filters.Add Description:="所有文件", Extensions:="*.*"
If Not .Show Then Exit Sub
fnm = .SelectedItems(1)
End With
'如果选定位置为空,直接转到插入图片
If TB.Cell(tbRow, tbColumn).Range.InlineShapes.Count = 0 Then GoTo InsPic
'如果选定位置不为空,判断表是否还有空格可插入图片
If TB.Cell(tbRows - 1, tbColumns).Range.InlineShapes.Count > 0 Then
MsgBox "表格已满,无法插入新图片!"
Exit Sub
End If
'--插入位置原有图片后移
For i = tbRows - 1 To tbRow Step -2
If i = tbRow Then
If tbColumns - tbColumn < 1 Then Exit For
TB.Cell(tbRow, tbColumn).Range.Select
Selection.EndKey Unit:=wdLine
Selection.MoveRight Unit:=wdCharacter, Count:=tbColumns - tbColumn, Extend:=wdExtend
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Cut
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Paste
Exit For
End If
TB.Cell(i, 1).Range.Select
Selection.EndKey Unit:=wdLine
Selection.MoveRight Unit:=wdCharacter, Count:=4, Extend:=wdExtend
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Cut
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Paste
TB.Cell(i - 2, tbColumns).Select
Selection.EndKey Unit:=wdLine
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Cut
TB.Cell(i, 1).Select
Selection.EndKey Unit:=wdLine
Selection.Paste
Next i
InsPic:
'插入选定的图片(来自文件)
TB.Cell(tbRow, tbColumn).Range.InlineShapes.AddPicture FileName:=fnm
If Len(TB.Cell(tbRow + 1, tbColumn).Range.Text) = 2 Then
i = InStrRev(fnm, "\")
j = InStrRev(fnm, ".")
If j < i Then j = i + 10
fnm = Mid(fnm, i + 1, j - i - 1)
TB.Cell(tbRow + 1, tbColumn).Range.Text = fnm
End If
OpenClipboard (0)
EmptyClipboard
CloseClipboard
End Sub

qee用

晕,5楼兄弟是什么意思啊?

[em06]为什么要限制字节呢?

玉皇大帝

看看什么结果？？？？？？？？？？？？？？？？？？？？

chylhr

Type MyRange
   MyPic As Range
   MyName As Range
End Type
Sub Main()
   Dim selRow As Integer, selColumn As Integer, int_Temp As Integer
   Dim MyTable As Table, myDialog As Dialog, PicPath As String, PicName As String
   If Selection.Tables.Count = 0 Then
      MsgBox "请选择一个有效的单元格。"
      Exit Sub
   End If
   If Selection.Tables(1).Cell(3, 5).Range.InlineShapes.Count = 1 Then
      MsgBox "图片已满。"
      Exit Sub
   End If
   If Selection.Cells.Count = 1 Then
      If Selection.InlineShapes.Count = 1 Then
         Set mytalbe = Selection.Tables(1)
         selRow = Selection.Cells(1).RowIndex
         selColumn = Selection.Cells(1).ColumnIndex
         Set myDialog = Dialogs(wdDialogInsertPicture)
         myDialog.Display
         PicPath = myDialog.Name
         If PicPath <> "" Then
            While PicName = ""
               PicName = InputBox("请输入图片的说明文字")
            Wend
            MyChange selRow, selColumn, PicPath, PicName
         Else
            Exit Sub
         End If
      Else
         MsgBox "请选择一个有效的单元格。"
      End If
   Else
      MsgBox "只能选择一个单元格。"
   End If
End Sub
Sub MyChange(selRow As Integer, selColumn As Integer, PicPath As String, PicName As String)
   Dim int_Temp As Integer, ArrayRange(10) As MyRange
   Dim selInt As Integer
   If selRow = 1 Then
      selInt = selColumn
   Else
      selInt = selColumn + 5
   End If
   For int_Temp = 10 To selInt Step -1
      If int_Temp <= 5 Then
         Set ArrayRange(int_Temp).MyPic = ActiveDocument.Tables(1).Cell(1, int_Temp).Range
         Set ArrayRange(int_Temp).MyName = ActiveDocument.Tables(1).Cell(2, int_Temp).Range
      Else
         Set ArrayRange(int_Temp).MyPic = ActiveDocument.Tables(1).Cell(3, int_Temp - 5).Range
         Set ArrayRange(int_Temp).MyName = ActiveDocument.Tables(1).Cell(4, int_Temp - 5).Range
      End If
      If int_Temp <= 6 Then
         Set ArrayRange(int_Temp - 1).MyPic = ActiveDocument.Tables(1).Cell(1, int_Temp - 1).Range
         Set ArrayRange(int_Temp - 1).MyName = ActiveDocument.Tables(1).Cell(2, int_Temp - 1).Range
      Else
         Set ArrayRange(int_Temp - 1).MyPic = ActiveDocument.Tables(1).Cell(3, int_Temp - 6).Range
         Set ArrayRange(int_Temp - 1).MyName = ActiveDocument.Tables(1).Cell(4, int_Temp - 6).Range
      End If
      If int_Temp = selInt Then
         Exit For
      End If
      ArrayRange(int_Temp - 1).MyName.Cut
      ArrayRange(int_Temp).MyName.Paste
      ArrayRange(int_Temp - 1).MyPic.Cut
      ArrayRange(int_Temp).MyPic.Paste
   Next
   ArrayRange(selInt).MyPic.InlineShapes.AddPicture FileName:=PicPath, Range:=ActiveDocument.Tables(1).Cell(selRow, selColumn).Range
   ArrayRange(selInt).MyName.Text = PicName
End Sub