Inserare de imagini în tabel cu 2-4 coloane

Inserare de imagini în tabel cu două, trei sau patru coloane

Instrucţiunile de mai jos se copie în aplicația Visual Basic, fereastra Code (detalii pe pagina Macrocomenzi )

Sub AdaugareImaginiInTabel()

'am folosit si adaptat codul de pe pagina

'http://www.vbaexpress.com/forum/showthread.php?44473-Insert-Multiple-Pictures-Into-Table-Word-With-Macro

'initial, codul era gandit pentru doua coloane

Dim nrcol As String 'a fost ales String (nu Integer) pentru a putea capta eroarea 13

Application.ScreenUpdating = False

nrcol = InputBox("Introduceti numarul coloanelor" & vbNewLine & "(min. 2, max. 4)")

If StrPtr(nrcol) = 0 Then

MsgBox "Nu ati dat click pe OK. Iesire din program..."

Exit Sub

End If

If nrcol < 2 Or nrcol > 4 Then

nrcol = InputBox("Ati introdus " & nrcol & " coloane." & vbNewLine & _

"Numarul coloanelor trebuie sa fie de 2, 3 sau 4." & vbNewLine & _

"Daca alegeti alta valoare, programul se va termina.")

If StrPtr(nrcol) = 0 Then

MsgBox "Nu ati dat click pe OK. Iesire din program..."

Exit Sub

End If

If nrcol < 2 Or nrcol > 4 Then

MsgBox "Iesire din program..."

Exit Sub

End If

Else

nume_img = MsgBox("Pastrez numele fisierului sub imagine?", vbYesNo + vbQuestion, "Cu nume fisier")

End If

'formatare text in locul unde se adauga tabelul

Selection.Font.Name = "Times New Roman"

Selection.Font.Size = 10

With Selection.ParagraphFormat

.LeftIndent = CentimetersToPoints(0)

.RightIndent = CentimetersToPoints(0)

.SpaceBefore = 0

.SpaceBeforeAuto = False

.SpaceAfter = 0

.SpaceAfterAuto = False

.LineSpacingRule = wdLineSpaceSingle

.Alignment = wdAlignParagraphCenter

.WidowControl = True

.KeepWithNext = False

.KeepTogether = False

.PageBreakBefore = False

.NoLineNumber = False

.Hyphenation = True

.FirstLineIndent = CentimetersToPoints(0)

.OutlineLevel = wdOutlineLevelBodyText

.CharacterUnitLeftIndent = 0

.CharacterUnitRightIndent = 0

.CharacterUnitFirstLineIndent = 0

.LineUnitBefore = 0

.LineUnitAfter = 0

'.MirrorIndents = False '!!! doar pentru Office mai nou

'.TextboxTightWrap = wdTightNone '!!! doar pentru Office mai nou

End With

Dim oTbl As Table, nrfoto As Long, j As Long, k As Long, StrTxt As String

'Selecteaza si insereaza imaginile

With Application.FileDialog(msoFileDialogFilePicker)

.Title = "Selectati imaginile si click OK"

.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"

.FilterIndex = 2

If .Show = -1 Then '-1 click OK, 0 click X sau Cancel

'Adaug tabel cu nrcol coloane si 2 linii pentru a prelua imaginile

'expression .Add(Range, NumRows, NumColumns, DefaultTableBehavior, AutoFitBehavior)

Set oTbl = Selection.Tables.Add(Selection.Range, 2, nrcol)

With oTbl

.AutoFitBehavior (wdAutoFitFixed)

If nrcol = 2 Then

.Columns.Width = CentimetersToPoints(8)

ElseIf nrcol = 3 Then

.Columns.Width = CentimetersToPoints(5)

ElseIf nrcol = 4 Then

.Columns.Width = CentimetersToPoints(4)

End If

End With

For nrfoto = 1 To .SelectedItems.Count

If nrcol = 2 Then

j = Int((nrfoto + 1) / 2) * 2 - 1 ' j este numarul liniei impare in care se insereaza imaginea

k = (nrfoto - 1) Mod 2 + 1 'k este nr coloanei in care se insereaza imaginea

ElseIf nrcol = 3 Then

j = 2 * Int((nrfoto + 2) / 3) - 1

k = (nrfoto - 1) Mod 3 + 1

ElseIf nrcol = 4 Then

j = 2 * Int((nrfoto + 3) / 4) - 1

k = (nrfoto - 1) Mod 4 + 1

End If

'Adauga cate randuri sunt necesare

If j > oTbl.Rows.Count Then

oTbl.Rows.Add

oTbl.Rows.Add

End If

'Insereaza imagine

ActiveDocument.InlineShapes.AddPicture _

FileName:=.SelectedItems(nrfoto), LinkToFile:=False, _

SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(k).Range

'Preia numele imaginii pentru Caption

StrTxt = Split(.SelectedItems(nrfoto), "\")(UBound(Split(.SelectedItems(nrfoto), "\")))

StrTxt = Split(StrTxt, ".")(0)

'Insereaza numele imaginii in celula de sub imagine

If nume_img = vbYes Then

With oTbl.Rows(j + 1).Cells(k).Range

'inainte de Enter

.InsertBefore vbCr

.Text = "Nr.inv.: " & StrTxt ' varianta: se poate adauga text inaintea numelui imaginii

.Text = StrTxt

End With

Else

'do nothing

End If

Next

Else

End If

End With

Application.ScreenUpdating = True

End Sub

Modul în care se poate folosi macrocomanda este prezentat pe YouTube: https://youtu.be/OvvYhQguBuM

Am găsit un supliment (add-in) care face acelaşi lucru, dar are mai multe opţiuni, pe pagina:

http://gregmaxey.com/word_tip_pages/photo_gallery_add_in.html