Showing posts with label VBA. Show all posts
Showing posts with label VBA. Show all posts

Tuesday, October 22, 2024

VBA PowerPoint to Create Microsoft Presentation from Text File

Objectives:

The purpose of this VBA PowerPoint code is to automate the process of exporting paragraphs from a Text file into a PowerPoint presentation. Each paragraph is transformed into a separate slide, with the option to include a title and a company logo. The text file path and logo image is hard coded; these can be modified as per the need. The code is as follows:

Sub CreatePresentationFromTextFile()
    Dim pptApp As Object
    Dim pptPres As Object
    Dim slideIndex As Integer
    Dim slide As Object
    Dim textFileName As String
    Dim fileNumber As Integer
    Dim lineContent As String
    Dim logoPath As String
    Dim logoShape As Object
    Dim slideWidth As Single
    Dim logoWidth As Single
    Dim logoHeight As Single
    
    ' Set the path to your text file and logo
    textFileName = "C:\Users\ajeet\Documents\test.txt" ' Change to your text file path
    logoPath = "G:\# Pictures\Image Common\logo.png" ' Change to your logo image path
    
    ' Logo size in inches (convert inches to points, 1 inch = 72 points)
    logoWidth = 1.13 * 72
    logoHeight = 1.13 * 72
    
    ' Create a new PowerPoint application and presentation
    Set pptApp = CreateObject("PowerPoint.Application")
    Set pptPres = pptApp.Presentations.Add
    pptApp.Visible = True
    
    ' Get slide width for logo positioning
    slideWidth = pptPres.PageSetup.SlideWidth
    
    ' Open the text file for reading
    fileNumber = FreeFile
    Open textFileName For Input As fileNumber
    
    ' Initialize slide index
    slideIndex = 1
    
    ' Read each line from the text file
    Do While Not EOF(fileNumber)
        Line Input #fileNumber, lineContent
        
        ' Check if the line content is not empty or blank
        If Trim(lineContent) <> "" Then
            ' Add a new slide with Title and Content layout
            Set slide = pptPres.Slides.Add(slideIndex, ppLayoutText)
            
            ' Set the title of the slide (you can customize this as needed)
            slide.Shapes(1).TextFrame.TextRange.Text = "Slide " & slideIndex
            
            ' Set the content of the slide (using Hindi font)
            With slide.Shapes(2).TextFrame.TextRange
                .Text = lineContent
                .Font.Name = "Mangal" ' You can change this to the preferred Hindi font
                .Font.Size = 15 ' Adjust font size as per your need
            End With
            
            ' Add the logo to the slide in the top right corner
            Set logoShape = slide.Shapes.AddPicture(logoPath, _
                            msoFalse, msoCTrue, slideWidth - logoWidth - 10, 10, logoWidth, logoHeight)
            
            ' Increment slide index for the next slide
            slideIndex = slideIndex + 1
        End If
    Loop
    
    ' Close the text file
    Close fileNumber
    
    ' Clean up
    Set slide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
End Sub

Thursday, September 26, 2024

VBA Code for Exporting Word Paragraphs to PowerPoint

Objective

The purpose of this VBA code is to automate the process of exporting paragraphs from a Microsoft Word document into a PowerPoint presentation. Each paragraph is transformed into a separate slide, with the option to include a title and a company logo. Additionally, the PowerPoint file is saved in a specified folder on the Desktop, with a unique filename that incorporates the current date and time.


Sub ExportParagraphsToPowerPoint()
    Dim PPTApp As Object
    Dim PPTPresentation As Object
    Dim PPTSlide As Object
    Dim PPTShape As Object
    Dim WordParagraph As Paragraph
    Dim SlideText As String
    Dim SlideTitle As String
    Dim SlideWidth As Single
    Dim SlideHeight As Single
    Dim LogoPath As String
    Dim TitleShape As Object
    Dim LogoShape As Object
    Dim DesktopPath As String
    Dim FolderPath As String
    Dim PPTFilePath As String
    Dim CurrentDateTime As String
    
    ' Define the path to your company logo image
    LogoPath = "C:\Users\ajeet\Desktop\Appliedk\logo.png"
    
    ' Get the path to the Desktop
    DesktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    FolderPath = DesktopPath & "\WordPpt" ' Folder where the PPT will be saved

    ' Check if folder exists, if not, create it
    If Dir(FolderPath, vbDirectory) = "" Then
        MkDir FolderPath
    End If
    
    ' Create a formatted date and time string for the filename
    CurrentDateTime = Format(Now, "yyyy-mm-dd_hh-nn-ss")
    
    ' Set the full path for saving the PowerPoint file
    PPTFilePath = FolderPath & "\ExportedPPT_" & CurrentDateTime & ".pptx"

    ' Create a new instance of PowerPoint (Make PowerPoint invisible during processing)
    On Error Resume Next
    Set PPTApp = GetObject(, "PowerPoint.Application")
    If PPTApp Is Nothing Then
        Set PPTApp = CreateObject("PowerPoint.Application")
    End If
    PPTApp.Visible = False ' Make PowerPoint invisible during processing
    On Error GoTo 0
    
    ' Create a new PowerPoint presentation
    Set PPTPresentation = PPTApp.Presentations.Add

    ' Get slide dimensions for reference
    SlideWidth = PPTPresentation.PageSetup.SlideWidth
    SlideHeight = PPTPresentation.PageSetup.SlideHeight

    ' Loop through each paragraph in the Word document
    For Each WordParagraph In ActiveDocument.Paragraphs
        SlideText = WordParagraph.Range.Text
        ' Remove any extra line breaks or spaces from the paragraph text
        SlideText = Trim(SlideText)
        
        ' Check if the paragraph contains text (skip empty paragraphs)
        If Len(SlideText) > 0 Then
            ' Add a new slide with a blank layout (layout ID 12)
            Set PPTSlide = PPTPresentation.Slides.Add(PPTPresentation.Slides.Count + 1, 12)
            
            ' Add a title at the top of the slide
            SlideTitle = "Slide " & PPTPresentation.Slides.Count ' You can customize the title format as needed
            Set TitleShape = PPTSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
                                                        Left:=50, Top:=20, Width:=SlideWidth - 100, Height:=50)
            TitleShape.TextFrame.TextRange.Text = SlideTitle
            With TitleShape.TextFrame.TextRange.Font
                .Name = "Arial" ' Change font style here
                .Size = 28      ' Set title font size
                .Bold = msoTrue ' Title in bold
            End With
            
            ' Set position and size of the text box (modify as needed)
            Dim textBoxLeft As Single
            Dim textBoxTop As Single
            Dim textBoxWidth As Single
            Dim textBoxHeight As Single
            
            ' Customize the position and size of the text box for the paragraph content
            textBoxLeft = 50       ' Distance from the left side (in points)
            textBoxTop = 100       ' Distance from the top (in points)
            textBoxWidth = 500     ' Width of the text box (in points)
            textBoxHeight = 300    ' Height of the text box (in points)
            
            ' Add the text box to the slide
            Set PPTShape = PPTSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
                                                      Left:=textBoxLeft, Top:=textBoxTop, _
                                                      Width:=textBoxWidth, Height:=textBoxHeight)
                                                      
            ' Add paragraph text to the text box
            PPTShape.TextFrame.TextRange.Text = SlideText
            
            ' Set font size and style for paragraph text
            With PPTShape.TextFrame.TextRange.Font
                .Name = "Arial" ' Change font style here
                .Size = 24      ' Set paragraph font size
                .Bold = msoFalse ' Optional: remove bold
            End With
            
            ' Add the company logo to the top-right corner
            Dim logoLeft As Single
            Dim logoTop As Single
            Dim logoWidth As Single
            Dim logoHeight As Single
            
            ' Set the position and size for the logo
            logoWidth = 100    ' Adjust width of logo
            logoHeight = 100   ' Adjust height of logo
            logoLeft = SlideWidth - logoWidth - 20 ' Positioned 20 points from the right
            logoTop = 20       ' Positioned 20 points from the top
            
            ' Add the logo image to the slide
            Set LogoShape = PPTSlide.Shapes.AddPicture(LogoPath, _
                                                       LinkToFile:=msoFalse, _
                                                       SaveWithDocument:=msoTrue, _
                                                       Left:=logoLeft, Top:=logoTop, _
                                                       Width:=logoWidth, Height:=logoHeight)
        End If
    Next WordParagraph
    
    ' Save the PowerPoint file in the "WordPpt" folder on the Desktop
    PPTPresentation.SaveAs PPTFilePath
    
    ' Close the PowerPoint presentation
    PPTPresentation.Close
    
    ' Cleanup
    Set PPTShape = Nothing
    Set PPTSlide = Nothing
    Set PPTPresentation = Nothing
    PPTApp.Quit ' Close PowerPoint
    Set PPTApp = Nothing
    
    ' Display "Done PPT" message
    MsgBox "Done PPT", vbInformation
End Sub 

Code Breakdown

  1. Variable Declarations:

    • The code begins by declaring various objects and variables, including:
      • PPTApp: The PowerPoint application object.
      • PPTPresentation: The PowerPoint presentation object.
      • PPTSlide: Represents individual slides within the presentation.
      • PPTShape: Represents shapes (text boxes) on the slides.
      • WordParagraph: Represents each paragraph in the Word document.
      • Other variables for text, dimensions, logo path, and file paths.
  2. Logo and Path Setup:

    • The path to the company logo image is defined with LogoPath.
    • The desktop path is retrieved using WScript.Shell to create a folder named WordPpt for saving the PowerPoint file.
    • If the folder does not exist, it is created using MkDir.
  3. File Naming:

    • The current date and time are formatted into a string (CurrentDateTime) to ensure a unique filename. This avoids overwriting previous files.
  4. PowerPoint Application Handling:

    • The code attempts to get an existing instance of PowerPoint. If not found, it creates a new instance.
    • The PowerPoint application is set to be invisible during the processing (PPTApp.Visible = False) to enhance user experience.
  5. Presentation Creation:

    • A new PowerPoint presentation is created using PPTApp.Presentations.Add.
  6. Looping Through Word Paragraphs:

    • The code iterates through each paragraph in the active Word document using a For Each loop.
    • It trims any leading or trailing spaces from the paragraph text and checks if it is non-empty.
    • For each valid paragraph, a new slide is added to the presentation with a blank layout.
  7. Adding Title and Content:

    • A title is added to each slide, formatted with specific font settings (e.g., Arial, size 28, bold).
    • A text box is created for the paragraph content, with customizable dimensions and font settings (e.g., Arial, size 24).
    • The text box is positioned within the slide based on specified left, top, width, and height parameters.
  8. Adding Company Logo:

    • The logo is added to the top-right corner of each slide, with customizable dimensions and positioning.
  9. Saving the Presentation:

    • The PowerPoint presentation is saved to the WordPpt folder on the Desktop, using the generated filename that includes the date and time.
  10. Cleanup and Closure:

    • The code cleans up by closing the PowerPoint presentation and quitting the PowerPoint application.
    • Finally, a message box is displayed to notify the user that the process is complete with the message "Done PPT".

Conclusion

This VBA code provides an efficient way to convert paragraphs from a Word document into a structured PowerPoint presentation, enhancing productivity for users who frequently create presentations from text content. The ability to customize titles, text formatting, and logo placement adds further utility, while the automatic file naming prevents data loss from overwriting.

Saturday, June 19, 2021

VBA - FileSystemObject Properties and Methods

Properties and Methods of the FileSystemObject Object

Description

Property/Method

BuildPath()

Appends information to a file path

CopyFile()

Copies a file from one location to another

CopyFolder()

Copies a folder from one location to another

CreateFolder()

Creates a new folder object

CreateTextfile()

Creates a new text file object

DeleteFile()

Removes a file

DeleteFolder()

Removes a folder object

DriveExists()

Determines whether a drive exists

Drives

Returns a Drives collection, containing all the available drive objects

FileExists()

Determines whether a file exists

FolderExists()

Determines whether a folder exists

GetAbsolutePathName()

Returns the absolute pathname for a file

GetBaseName()

Gets the base name of the last component

GetDrive()

Gets the drive letter for a file

GetDriveName()

Gets the drive name on which a file resides

ExtensionName()

Returns the extension for a file

GetFile()

Gets the file object

GetFileName()

Gets the name of a file

GetFolder()

Gets the folder name that contains a file

GetParentFolderName()

Gets the parent folder's name

GetSpecialFolder()

Gets the folder names for special folders

GetTempName()

Creates a randomly generated temporary file

MoveFile()

Moves a file from one location to another

MoveFolder()

Moves a folder and its contents from one location to another

OpentextFile()

Opens a text file stream to a file



Thursday, September 10, 2020

VBA Shortcuts

The shortcut to open the component dialog box in Visual Basic Editor

CTRL, T



Monday, August 10, 2020

Excel VBA RoundDown and RoundUp functions

Function TestMin(DMin As Double)
        If DMin < 100 Then
            DMin = WorksheetFunction.RoundDown(DMin, 0)
        ElseIf DMin < 1000 Then
            DMin = WorksheetFunction.RoundDown(DMin, -1)
        ElseIf DMin < 10000 Then
            DMin = WorksheetFunction.RoundDown(DMin, -2)
        ElseIf DMin < 100000 Then
            DMin = WorksheetFunction.RoundDown(DMin, -3)
        ElseIf DMin < 1000000 Then
            DMin = WorksheetFunction.RoundDown(DMin, -4)
        End If
        TestMin = DMin
End Function
Function TestMax(DMax As Double)
        If DMax < 100 Then
            DMax = WorksheetFunction.RoundUp(DMax, 0)
        ElseIf DMax < 1000 Then
            DMax = WorksheetFunction.RoundUp(DMax, -1)
        ElseIf DMax < 10000 Then
            DMax = WorksheetFunction.RoundUp(DMax, -2)
        ElseIf DMax < 100000 Then
            DMax = WorksheetFunction.RoundUp(DMax, -3)
        ElseIf DMax < 1000000 Then
            DMax = WorksheetFunction.RoundUp(DMax, -4)
        End If
        TestMax = DMax
End Function
Sub test()
    MsgBox TestMin(87789.89)
    MsgBox TestMax(97979.89)
End Sub

VBA Excel How to check the date is same after reversal of day and month

Function isBeforeAfterDateSame(strDateBefore As String) As Boolean
    Dim x As String
    Dim y As String
    Dim z As String
    Dim strInDate As String
    Dim strDateAfter As String
    Dim flag As Boolean
    Dim result As Date
    
    strInDate = strDateBefore
    
    If Len(strInDate) >= 8 And Len(strInDate) <= 10 Then
        '' date format is with /  digit separator
        If VBA.InStr(strInDate, "/") > 0 Then
            If VBA.IsDate(strInDate) Then
            
                x = VBA.Split(strInDate, "/")(0)
                y = VBA.Split(strInDate, "/")(1)
                z = VBA.Split(strInDate, "/")(2)
                
                If Len(x) = 1 Then x = "0" & x
                If Len(y) = 1 Then y = "0" & y
                
                strInDate = x & "/" & y & "/" & z

                result = DateValue(strInDate)
                strOutDate = CStr(result)
            
                x = VBA.Split(strOutDate, "/")(0)
                y = VBA.Split(strOutDate, "/")(1)
                z = VBA.Split(strOutDate, "/")(2)
                
                If Len(x) = 1 Then x = "0" & x
                If Len(y) = 1 Then y = "0" & y
                
                strOutDate = x & "/" & y & "/" & z

                If strOutDate = strInDate Then
                    flag = True
                End If
            End If
        End If
    End If
    
    isBeforeAfterDateSame = flag
    
End Function

VBA Excel How to Get the nearest Monday of a date

Function GetMonday(strDate As String) As Date
    ''get the nearest Monday before the given date
    Dim wkNum As Integer
    Dim dNearestMonday As Date
    wkNum = Weekday(strDate, vbMonday)
    
    Select Case wkNum
        Case 1:
            dNearestMonday = DateValue(strDate)
        Case 2:
            dNearestMonday = DateValue(strDate) - 1
        Case 3:
            dNearestMonday = DateValue(strDate) - 2
        Case 4:
            dNearestMonday = DateValue(strDate) - 3
        Case 5:
            dNearestMonday = DateValue(strDate) - 4
        Case 6:
            dNearestMonday = DateValue(strDate) - 5
        Case 7:
            dNearestMonday = DateValue(strDate) - 6
        Case Else
            dNearestMonday = #1/1/1900#
    End Select
    GetMonday = dNearestMonday
End Function

Excel VBA How to change value of a cell using Scroll Bar

Private Sub ScrollBar1_Change()
    Application.EnableEvents = False
    ScrollBar1.Min = -100
    ScrollBar1.Max = 100
    ScrollBar1.SmallChange = 1
    ScrollBar1.LargeChange = 5
    ShtGraph1.Range("A5").Value = ScrollBar1.Value * 0.01
    Application.EnableEvents = True
End Sub

Private Sub ScrollBar1_Scroll()
    Application.EnableEvents = False
    ScrollBar1.Min = -100
    ScrollBar1.Max = 100
    ScrollBar1.SmallChange = 1
    ScrollBar1.LargeChange = 5
    ShtGraph1.Range("A5").Value = ScrollBar1.Value * 0.01
    Application.EnableEvents = True
End Sub

NOTE: The A5 cell should be in percentage format to see change of percentage value.

VBA Excel How to Clear All data in Excel sheet Range Except Formulas

Sub ClearConstantData(rng As Range)
    Dim cl As Range
    For Each cl In rng.Cells
        If Not cl.HasFormula Then
            If cl.Value <> "" Or Not (IsEmpty(cl)) Then
                cl.ClearContents
            End If
        End If
    Next
End Sub

Tuesday, July 7, 2020

VBA Thick Border Around Range



Option Explicit

Sub ThickBorderAround(rng As Range)
    rng.Borders(xlDiagonalDown).LineStyle = xlNone
    rng.Borders(xlDiagonalUp).LineStyle = xlNone
    With rng.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With rng.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With rng.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With rng.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
End Sub

VBA Replace Text In Range in Excel


Sub ReplaceTextInRange(sht As Worksheet, rngSearch As Range, strFindText As String,  strReplaceText As String)

    Dim cellFound As Range
    Dim firstAddress As String

    ActiveWorkbook.Sheets(sht.Name).Activate
 
    With rngSearch
        Set cellFound = .Find(strFindText, LookIn:=xlValues)
        If Not cellFound Is Nothing Then
            firstAddress = cellFound.Address
            Do
                cellFound.Value = VBA.Replace(cellFound.Value, strFindText, strReplaceText)
                Set cellFound = .FindNext(cellFound)
''            Loop While cellFound.Address <> firstAddress
            Loop Until cellFound Is Nothing
        End If
    End With

End Sub

Sheet Password Breaker

Sub PasswordBreaker()

'Breaks worksheet password protection.

Dim i As Integer, j As Integer, k As Integer
Dim l As Integer, m As Integer, n As Integer
Dim i1 As Integer, i2 As Integer, i3 As Integer
Dim i4 As Integer, i5 As Integer, i6 As Integer
On Error Resume Next
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If ActiveSheet.ProtectContents = False Then
MsgBox "One usable password is " & Chr(i) & Chr(j) & _
Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
Exit Sub
End If
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
End Sub

Sunday, June 28, 2020

VBA Statements Cheat sheet


 Brief Information of VBA Statements

VBA Statement
What It Does
AppActivate
Activates an application window
Beep
Sounds a tone via the computer's speaker
Call
Transfers control to another procedure
ChDir
Changes the current directory
ChDrive
Changes the current drive
Close
Closes a text file
Const
Declares a constant value
Date
Sets the current system date
Declare
Declares a reference to an external procedure in a Dynamic Link Library (DLL)
DeleteSetting
Deletes a section or key setting from an application's entry in the Windows Registry
Dim
Declares variables and (optionally) their data types
Do-Loop
Loops through a set of instructions
End
Used by itself, exits the program; also used to end a block of statements that begin with If, With, Sub, Function, Property, Type, or Select
Erase
Re-initializes an array
Error
Simulates a specific error condition
Exit Do
Exits a block of Do-Loop code
Exit For
Exits a block of For-Next code
Exit Function
Exits a Function procedure
Exit Property
Exits a property procedure
Exit Sub
Exits a subroutine procedure
FileCopy
Copies a file
For Each-Next
Loops through a set of instructions for each member of a series
For-Next
Loops through a set of instructions a specific number of times
Function
Declares the name and arguments for a Function procedure
Get
Reads data from a text file
GoSub...Return
Branches to and returns from a procedure
GoTo
Branches to a specified statement within a procedure
If-Then-Else
Processes statements conditionally
Input #
Reads data from a sequential text file
Kill
Deletes a file from a disk
Let
Assigns the value of an expression to a variable or property
Line Input #
Reads a line of data from a sequential text file
Load
Loads an object but doesn't show it
Lock...Unlock
Controls access to a text file
Mid
Replaces characters in a string with other characters
MkDir
Creates a new directory
Name
Renames a file or directory
On Error
Gives specific instructions for what to do in the case of an error
On...GoSub
Branches, based on a condition
On...GoTo
Branches, based on a condition
Open
Opens a text file
Option Base
Changes the default lower limit for arrays
Option Compare
Declares the default comparison mode when comparing strings
Option Explicit
Forces declaration of all variables in a module
Option Private
Indicates that an entire module is Private
Print #
Writes data to a sequential file
Private
Declares a local array or variable
Property Get
Declares the name and arguments of a Property Get procedure
Property Let
Declares the name and arguments of a Property Let procedure
Property Set
Declares the name and arguments of a Property Set procedure
Public
Declares a public array or variable
Put
Writes a variable to a text file
RaiseEvent
Fires a user-defined event
Randomize
Initializes the random number generator
ReDim
Changes the dimensions of an array
Rem
Specifies a line of comments (same as an apostrophe ['])
Reset
Closes all open text files
Resume
Resumes execution when an error-handling routine finishes
RmDir
Removes an empty directory
SaveSetting
Saves or creates an application entry in the Windows Registry
Seek
Sets the position for the next access in a text file
Select Case
Processes statements conditionally
SendKeys
Sends keystrokes to the active window
Set
Assigns an object reference to a variable or property
SetAttr
Changes attribute information for a file
Static
Declares variables at the procedure level so that the variables retain their values as long as the code is running
Stop
Pauses the program
Sub
Declares the name and arguments of a Sub procedure
Time
Sets the system time
Type
Defines a custom data type
Unload
Removes an object from memory
While...Wend
Loops through a set of instructions as long as a certain condition remains true
Width #
Sets the output line width of a text file
With
Sets a series of properties for an object
Write #
Writes data to a sequential text file

Hot Topics