Caros programadores, teria como, usando VBA colocar estes texto na segunda coluna de uma tabela. Cada texto deste tem uma imagem correspondente. A imagem eu consegui colocar na primeira coluna, mas o texto não. Se puderem me ajudar agradeço. Abaixo está o código que eu tento adaptar para minha necessidade. Nome: Background.jpg Tipo: Jpeg Tamanho: 48.94 KB Caminho: /private/var/mobile/Library/ ---------------------------------- Nome: IMG_0001.THM Tipo: Jpeg Tamanho: 4.19 KB Caminho: /private/var/mobile/Media/DCIM/100APPLE/ ----------------------------- Nome: IMG_0002.JPG Tipo: Jpeg Tamanho: 318.18 KB MetaDados: EquipMake: Apple EquipModel: iPhone XResolution: 72.000000 YResolution: 72.000000 ResolutionUnit: 2 DateTime: 2009:07:07 12:27:58 GpsLatitudeRef: S GpsLongitudeRef: W GpsGpsTime: 12.000000 27.000000 29.840000 Caminho: /private/var/mobile/Media/DCIM/100APPLE/ ------------------------------ Nome: P200010_13.30.jpg Tipo: Jpeg Tamanho: 1.09 MB MetaDados: EquipMake: LG Electronics EquipModel: KP570 SoftwareUsed: LGE_SW Caminho: External/Pictures ------------------------ Nome: P060410_19.02.jpg Tipo: Jpeg Tamanho: 265.68 KB MetaDados: EquipMake: LG Electronics EquipModel: KP570 SoftwareUsed: LGE_SW Caminho: External/Pictures ----------------------- Nome: Z000410_12.28.jpg Tipo: Jpeg Tamanho: 1.11 MB MetaDados: EquipMake: LG Electronics EquipModel: KP570 SoftwareUsed: LGE_SW Caminho: External/Pictures ----------------- Sub macro1000()
Dim j As Integer
Dim i As Long
Dim search As String
Dim txt As String
Dim para As paragraph
Selection.WholeStory
ActiveDocument.Content.ParagraphFormat.TabStops.ClearAll
Selection.ClearFormatting
'Format text
With Selection.Font
' the Latin text font name and size.
.Name = "Verdana"
.Size = 10 ' Bold and Italic are the Font Style...
.Bold = False
.Italic = True
.Underline = wdUnderlineNone
.UnderlineColor = wdColorAutomatic
End With
'Format paragraphs.
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceAtLeast
.LineSpacing = 12
.Alignment = wdAlignParagraphLeft
.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
End With
‘Delete tabs.
Dim oRng As Word.Range
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.Text = "^t"
While .Execute
oRng.Delete
Wend
End With
'Resize pictures > 500 pixels.
Set DocThis = ActiveDocument
iILShapeCount = DocThis.InlineShapes.Count
For j = 1 To iILShapeCount
If PointsToPixels(DocThis.InlineShapes(j).Width, False) > 500 Then
ActiveDocument.InlineShapes(j).Height = _
ActiveDocument.InlineShapes(j).Height / 2
ActiveDocument.InlineShapes(j).Width = _
ActiveDocument.InlineShapes(j).Width / 2
End If
Next
‘Imagens - put border.
Set DocThis = ActiveDocument
iILShapeCount = DocThis.InlineShapes.Count
For k = 1 To iILShapeCount
With Selection.InlineShapes(k)
With .Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = wdColorAutomatic
End With
.Borders.Shadow = False
End With
With Options
.DefaultBorderLineStyle = wdLineStyleSingle
.DefaultBorderLineWidth = wdLineWidth100pt
.DefaultBorderColor = wdColorAutomatic
End With
Next
'Delete data without interesting.
search = "Exif"
For i = ActiveDocument.Paragraphs.Count To 2 Step -1
ActiveDocument.Paragraphs(i).Range.Select
txt = ActiveDocument.Paragraphs(i).Range.Text
If InStr((txt), search) Then
ActiveDocument.Paragraphs(i).Range.Delete
End If
Next
search = "JPEG"
For i = ActiveDocument.Paragraphs.Count To 2 Step -1
ActiveDocument.Paragraphs(i).Range.Select
txt = ActiveDocument.Paragraphs(i).Range.Text
If InStr((txt), search) Then
ActiveDocument.Paragraphs(i).Range.Delete
End If
Next
search = "Image"
For i = ActiveDocument.Paragraphs.Count To 2 Step -1
ActiveDocument.Paragraphs(i).Range.Select
txt = ActiveDocument.Paragraphs(i).Range.Text
If InStr((txt), search) Then
ActiveDocument.Paragraphs(i).Range.Delete
End If
Next
search = "Orientation"
For i = ActiveDocument.Paragraphs.Count To 2 Step -1
ActiveDocument.Paragraphs(i).Range.Select
txt = ActiveDocument.Paragraphs(i).Range.Text
If InStr((txt), search) Then
ActiveDocument.Paragraphs(i).Range.Delete
End If
Next
'Put blank paragraphs and add a table and add a reference to section break (BP).
For i = ActiveDocument.Paragraphs.Count To 2 Step -1
ActiveDocument.Paragraphs(i).Range.Select
If ActiveDocument.Paragraphs(i).Range.Characters.Count = 1 Then
Selection.TypeParagraph
Selection.TypeParagraph
Selection.TypeParagraph
Selection.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:=2
Selection.Tables.Item(1).Cell(1, 1).Column.Width = 220
Selection.Tables.Item(1).Cell(1, 2).Column.Width = 220
Selection.Tables.Item(1).Cell(1, 1).Range.Text = "Imagem"
Selection.Tables.Item(1).Cell(1, 2).Range.Text = "Dados de Exif"
Selection.TypeText Text:=".BP "
Selection.TypeParagraph
End If
Next
‘Add section break
For Each para In ActiveDocument.Paragraphs
If para.Range.Words.first = "." Then
If para.Range.Words(2) = "BP " Then
para.Range.InsertBreak Type:=wdSectionBreakContinuous
para.Range.Words.first.Delete
para.Range.Words.first.Delete
para.Range.Delete
End If
End If
Next para
With ActiveDocument
.Sections.first.Range.Delete
End With
With ActiveDocument
.Sections.first.Range.Delete
End With
With ActiveDocument
.Sections.Last.Range.Delete
End With
With ActiveDocument.Sections.first.Range
.Collapse direction:=wdCollapseEnd
.InsertAfter "IMAGENS"
End With
‘Put imagens inside the table
iShapeCount = DocThis.InlineShapes.Count
For i = 1 To iShapeCount
ActiveDocument.InlineShapes(i).Range.Select
With Selection
.Cut
DocThis.Tables(i).Cell(2, 1).Range.Paste
End With
Next i
End Sub