codewala

code it

Macro to retain paragraph formatting when text is copied from Word to PowerPoint

In my earlier post I had mentioned about paragraph formatting is lost when text is copied from Word to PowerPoint.

Wrote a macro in PowerPoint to retain the paragraph formatting of the copied text from Word to PowerPoint.


'--------------------------------------------------
Option Explicit
'
'
'
Sub CopyTextFromWordWithParaFormat()
'
' FOR WORD
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdFile As String
Dim oTable As Word.Table
Dim oRow As Word.Row
Dim oParas As Word.Paragraphs
Dim oPara As Word.Paragraph
Dim paraBullet()
Dim paraIndentLevel()
Dim p As Long
Dim wdParaCount As Long
Dim counter As Long
'
' FOR POWERPOINT
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim oSlide As Slide
Dim oShape As PowerPoint.Shape
Dim ppParaCount As Long
Dim path As String
'
' INITILIZE
Set ppApp = PowerPoint.Application
Set ppPres = ActivePresentation
path = ppPres.path
p = 1
counter = 1
wdParaCount = 0
ppParaCount = 0
'
'
'-----------------------------------------------------
' SWITCH TO WORD TO READ THE CONTENT
'-----------------------------------------------------
Set wdApp = CreateObject("Word.Application")
wdFile = path & "/" & "sample.doc"
'
Set wdDoc = wdApp.Documents.Open(wdFile)
wdApp.Visible = True
wdDoc.Activate
'
'
' READ WORD TABLE
Set oTable = wdDoc.Tables(1)
Set oRow = oTable.Rows(1)
Set oParas = oRow.Cells(1).Range.Paragraphs
'
wdParaCount = oParas.Count
'
' GET PARAFORMATTING OF EACH PARAGRAPH
ReDim paraBullet(wdParaCount)
ReDim paraIndentLevel(wdParaCount)
'
For p = 1 To wdParaCount
'
Set oPara = oParas(p)
'
' ONLY INCLUDE THOSE PARA'S WHICH ARE NOT EMPTY
If (Len(oPara.Range.Text) > 1) Then
paraBullet(counter) = oPara.Range.ListFormat.ListType
paraIndentLevel(counter) = oPara.Range.ListFormat.ListLevelNumber
counter = counter + 1
End If
'
Next p
'
'
' COPY THE TEXT FROM WORD
oRow.Cells(1).Select
SendKeys "^c", 1
'
'
'---------------------------------------------------------
' SWITCH TO POWERPOINT TO PASTE AND FORMAT THE COPIED TEXT
'---------------------------------------------------------
'
ppApp.Activate
'
With ActivePresentation
'
Set oSlide = .Slides(1)
Set oShape = oSlide.Shapes("Rectangle 3")
'
' PASTE THE TEXT COPIED FROM WORD INTO THE SHAPE
oShape.TextFrame.TextRange.Text = ""
oShape.TextFrame.TextRange.Characters(1, 0).Select
SendKeys "^v", 1
ppParaCount = oShape.TextFrame.TextRange.Paragraphs.Count
'
'
' FIRST CLEAR THE PARAGRAPH FORMATTING FROM POWERPOINT
oShape.TextFrame.TextRange.Paragraphs(1, ppParaCount).ParagraphFormat.Bullet.Type = ppBulletNone
oShape.TextFrame.TextRange.Paragraphs(1, ppParaCount).IndentLevel = 0
'
' APPLY THE WORD PARAGRAPH FORMATTING INTO POWERPOINT
For p = 1 To ppParaCount
'
If (paraBullet(p) = 2 Or paraBullet(p) = 3) Then ' 2 for bullet and 3 for numbered bullet
oShape.TextFrame.TextRange.Paragraphs(p).ParagraphFormat.Bullet.Visible = msoTrue
oShape.TextFrame.TextRange.Paragraphs(p).IndentLevel = paraIndentLevel(p) + 1
End If
'
Next p
'
End With
'
' EXIT WORD
wdDoc.Close
wdApp.Quit
'
' CLEAR ARRAY
ReDim paraBullet(0)
ReDim paraIndentLevel(0)
'
' CLEAR OBJECTS
Set oShape = Nothing
Set oSlide = Nothing
Set oPara = Nothing
Set oRow = Nothing
Set oTable = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
'
MsgBox "process complete."
'
End Sub

‘————————————————–

December 29, 2010 Posted by | PowerPoint, VBA, Word | Leave a comment

Add table number to each table from # table onwards in Word

I had a word document with many tables. The task was to add an ID (#) in the first row of the table. The insersion of the ID needed to start from certain Table onwards. Came up with a macro which when executed – will popup an input box – type the table number from where the ID needs to be inserted from and click ok.


'--------------------------------------------
Option Explicit
'
Sub AddTableID()
'
Dim tableIndex As String
Dim oDoc As Document
Dim oTables As Tables
Dim oTable As Table
Dim oRow As Row
Dim totalTables As Long
Dim t As Long
Dim tableID As Long
'
tableID = 1
tableIndex = InputBox(Prompt:="Add Table ID from which Table onwards", Title:="", Default:="")
If tableIndex = vbNullString Then
' dont do anything
Else
'
Set oDoc = ActiveDocument
Set oTables = oDoc.Tables
totalTables = oTables.Count
'
For t = tableIndex To totalTables
Set oTable = oTables(t)
'oTable.Rows.Add BeforeRow:=oTable.Rows(1)
Set oRow = oTable.Rows(1)
oRow.Cells(1).Range.Text = "Table ID : " & tableID
tableID = tableID + 1
Next t
'
Set oRow = Nothing
Set oTable = Nothing
Set oTables = Nothing
Set oDoc = Nothing
'
End If
'
End Sub
'--------------------------------------------

add table id

December 26, 2010 Posted by | VBA, Word | Leave a comment

Extract embeded Flash file from MS-Office documents

Found a nice code from web on how to extract .SWF file from a scrap file.
Steps on how to extract the embeded Flash File from MS-Office Documents.

1. Select and copy the embbeded flash file from the document.

2. Paste it in a folder. A scrap file will be created.

3. Paste the VBA code given below in Excel and run it. It will ask for the scrap file. Select it and click ok. The Flash will be extracted on the same path where the scrap file is.


'------------------------------------------------------
Sub ExtractFlashFromScrapFile()

Dim tmpFileName As String
Dim FileNumber As Integer
Dim myFileId As Long
Dim MyFileLen As Long
Dim myIndex As Long
Dim swfFileLen As Long
Dim i As Long
Dim swfArr() As Byte
Dim myArr() As Byte

tmpFileName = Application.GetOpenFilename(“Select Scrap File (*.*), *.*”, , “Select Scrap File”)

If tmpFileName = “False” Then Exit Sub

myFileId = FreeFile

Open tmpFileName For Binary As #myFileId

MyFileLen = LOF(myFileId)

ReDim myArr(MyFileLen – 1)

Get myFileId, , myArr()

Close myFileId

Application.ScreenUpdating = False

i = 0

Do While i < MyFileLen

If myArr(i) = &H46 Then

If myArr(i + 1) = &H57 And myArr(i + 2) = &H53 Then
MsgBox “&H46”

swfFileLen = CLng(&H1000000) * myArr(i + 7) + CLng(&H10000) * myArr(i + 6) + CLng(&H100) * myArr(i + 5) + myArr(i + 4)

ReDim swfArr(swfFileLen – 1)

For myIndex = 0 To swfFileLen – 1
swfArr(myIndex) = myArr(i + myIndex)
Next myIndex
Exit Do

Else
i = i + 3
End If

Else
i = i + 1
End If

Loop

myFileId = FreeFile

tmpFileName = Left(tmpFileName, Len(tmpFileName) – 4) & “.swf”

Open tmpFileName For Binary As #myFileId

Put #myFileId, , swfArr

Close myFileId

MsgBox “Save the extracted SWF Flash as [ ” & tmpFileName & ” ]”

End Sub

‘——————————————————

December 26, 2010 Posted by | Excel, VBA | Leave a comment

Workaround to retain the paragraph formatting of text when copied from Word to Powerpoint

While developing an automation program which will copy text from Word file into PowerPoint, came across this issue of PowerPoint not able to retain the paragraph formatting of the text. This happens when the text has mix of bulleted and non-bulleted paragraphs. It seems that PowerPoint can only retain the formatting if each paragraph in Word is bulleted. Refer the screenshots to see the issue and the workaround.

Formatted paragraph text in word

When Copied into PowerPoint

Modified paragraph text in word

When Copied into PowerPoint

December 25, 2010 Posted by | PowerPoint, Word | 1 Comment

Macro to delete empty rows from a table in word


Sub DeleteEmptyRowsFromTable()
'
Dim oDoc As Document
Dim oTable As Table
Dim oRow As Row
Dim totalRows As Long
Dim textInCell As String
Dim i As Long
'
Set oDoc = ActiveDocument
Set oTable = oDoc.Tables(1)
'
totalRows = oTable.Rows.Count
'
For i = totalRows To 1 Step -1
Set oRow = oTable.Rows(i)
textInCell = CleanText(oRow.Cells(1).Range.Text)
'
If textInCell = "" Then
oRow.Delete
End If
Next i
'
End Sub
'
'
'
Function CleanText(pm_str As String) As String
'
pm_str = Trim(pm_str)
pm_str = Replace$(pm_str, "", "")
pm_str = Replace$(pm_str, Chr(13), "") ' vbCrLf (return)
pm_str = Replace$(pm_str, Chr(7), "") ' vbCrLf (return)
CleanText = pm_str
'
End Function

December 24, 2010 Posted by | VBA, Word | Leave a comment