Programmatically combine slides from multiple presentations into a single presentation - automation

I need to automate the creation of a presentation (either OpenOffice or Powerpoint). The presentation should take the first two slides of each of the presentations in a given directory, and then combine them into a single presentation. I'm confused as to what approach I should take to solve this. Any pointers will be appreciated.

Talking about PowerPoint, you would use a VBA Macro to do the job, something like
Sub Pull()
Dim SrcDir As String, SrcFile As String
SrcDir = PickDir()
If SrcDir = "" Then Exit Sub
SrcFile = Dir(SrcDir & "\*.ppt")
Do While SrcFile <> ""
ImportFromPPT SrcDir + "\" + SrcFile, 1, 2
SrcFile = Dir()
Loop
End Sub
Selecting your source directory you can use this function
Private Function PickDir() As String
Dim FD As FileDialog
PickDir = ""
Set FD = Application.FileDialog(msoFileDialogFolderPicker)
With FD
.Title = "Pick a directory to work on"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 0 Then
PickDir = .SelectedItems(1)
End If
End With
End Function
Now - the main point is inserting slides from another PPT while preserving the source format. This is a tricky thing, as the PPT VBA InsertFromFile method is of no good use. Microsoft gave us good time to figure it out the hard way in countless 20hrs debuging sessions :-) and you need to type a lot of code to get it done correctly - far more complicated than using the dialogue manually, in particular if your source slide deviates from your source master slide.
If your PPT's are sticking to their masters, you can safely omit all code between the ">>>>"
Private Sub ImportFromPPT(FileName As String, SlideFrom As Long, SlideTo As Long)
Dim SrcPPT As Presentation, SrcSld As Slide, Idx As Long, SldCnt As Long
Set SrcPPT = Presentations.Open(FileName, , , msoFalse)
SldCnt = SrcPPT.Slides.Count
If SlideFrom > SldCnt Then Exit Sub
If SlideTo > SldCnt Then SlideTo = SldCnt
For Idx = SlideFrom To SlideTo Step 1
Set SrcSld = SrcPPT.Slides(Idx)
SrcSld.Copy
With ActivePresentation.Slides.Paste
.Design = SrcSld.Design
.ColorScheme = SrcSld.ColorScheme
' if slide is not following its master (design, color scheme)
' we must collect all bits & pieces from the slide itself
' >>>>>>>>>>>>>>>>>>>>
If SrcSld.FollowMasterBackground = False Then
.FollowMasterBackground = False
.Background.Fill.Visible = SrcSld.Background.Fill.Visible
.Background.Fill.ForeColor = SrcSld.Background.Fill.ForeColor
.Background.Fill.BackColor = SrcSld.Background.Fill.BackColor
' inspect the FillType object
Select Case SrcSld.Background.Fill.Type
Case Is = msoFillTextured
Select Case SrcSld.Background.Fill.TextureType
Case Is = msoTexturePreset
.Background.Fill.PresetTextured (SrcSld.Background.Fill.PresetTexture)
Case Is = msoTextureUserDefined
' TextureName gives a filename w/o path
' not implemented, see picture handling
End Select
Case Is = msoFillSolid
.Background.Fill.Transparency = 0#
.Background.Fill.Solid
Case Is = msoFillPicture
' picture cannot be copied directly, need to export and re-import slide image
If SrcSld.Shapes.Count > 0 Then SrcSld.Shapes.Range.Visible = False
bMasterShapes = SrcSld.DisplayMasterShapes
SrcSld.DisplayMasterShapes = False
SrcSld.Export SrcPPT.Path & SrcSld.SlideID & ".png", "PNG"
.Background.Fill.UserPicture SrcPPT.Path & SrcSld.SlideID & ".png"
Kill (SrcPPT.Path & SrcSld.SlideID & ".png")
SrcSld.DisplayMasterShapes = bMasterShapes
If SrcSld.Shapes.Count > 0 Then SrcSld.Shapes.Range.Visible = True
Case Is = msoFillPatterned
.Background.Fill.Patterned (SrcSld.Background.Fill.Pattern)
Case Is = msoFillGradient
' inspect gradient type
Select Case SrcSld.Background.Fill.GradientColorType
Case Is = msoGradientTwoColors
.Background.Fill.TwoColorGradient
SrcSld.Background.Fill.GradientStyle , _
SrcSld.Background.Fill.GradientVariant
Case Is = msoGradientPresetColors
.Background.Fill.PresetGradient _
SrcSld.Background.Fill.GradientStyle, _
SrcSld.Background.Fill.GradientVariant, _
SrcSld.Background.Fill.PresetGradientType
Case Is = msoGradientOneColor
.Background.Fill.OneColorGradient _
SrcSld.Background.Fill.GradientStyle, _
SrcSld.Background.Fill.GradientVariant, _
SrcSld.Background.Fill.GradientDegree
End Select
Case Is = msoFillBackground
' Only shapes - we shouldn't come here
End Select
End If
' >>>>>>>>>>>>>>>>>>>>
End With
Next Idx
End Sub
The code doesn't check for read-only or password protected fies and will crash on them. Also be careful not to run over the collector file itself. Otherwise it should work. I must admit I haven't reviewed the code for a long time ;-)

You can google "powerpoint join" to find a useful tool to join many ppts.

I'm glad #miked was able to get you what you needed.
Another method to consider, if using .NET, is discussed in this post

A simple and fast solution:
I := Presentation.Slides.InsertFromFile(FileName,X,StartSlideNo,EndSlideNo);
Presentation.Slides.Item(I).ApplyTheme(FileName);
Presentation.Slides.Item(I).ApplyTemplate(FileName);
Note:
X is place to insert slide in presentation
I is actual place where slide was inserted
Code is written in Delphi/Pascal but you can convert it easelly ...

You can do this with Aspose.Slides for .NET. It even allows joining OpenOffice and PowerPoint presentations together. View this article.
var presentation1 = new Presentation("presentation1.pptx");
var presentation2 = new Presentation("presentation2.odp");
var mergedPresentation = new Presentation();
while (mergedPresentation.Slides.Count > 0) mergedPresentation.Slides.RemoveAt(0);
// Adding two slides from the first PPTX presentation
mergedPresentation.Slides.AddClone(presentation1.Slides[0]);
mergedPresentation.Slides.AddClone(presentation1.Slides[1]);
// Adding two slides from the second OPD presentation
mergedPresentation.Slides.AddClone(presentation2.Slides[0]);
mergedPresentation.Slides.AddClone(presentation2.Slides[1]);
mergedPresentation.Save("mergedPresentation.pptx", SaveFormat.Pptx);

Related

Transferring text range from 1 power point to another to change template

I am very new with Powerpoint VBA and would like to know if there is a short way to transfer one text range from PowerPoint A to another text range located in Powerpoint B in a specific sequence.
Page a1 = b1
Page a2 = b2
Page a3 = b3
The template is changing and I need to adapt 5 powerpoints of 100 slides so I tought it would be easier with this solution.
Thank you in advance for your help.
PRECISION : I don't want to copy and paste the text range but to copy the text inside the range to put it inside the new range. Please find below the code I already have but It doesnt' Paste it inside my new range.
Sub copier_texte() 'je veux copier le contenu de la forme, et non pas la forme en entier
Dim nb_slide As Integer
nb_slide = ActivePresentation.Slides.Count
With ActivePresentation
.Slides(1).Shapes(2).TextFrame.TextRange.Copy 'je sélectionne uniquement le contenu de la forme
For i = 2 To .Slides.Count
.Slides(i).Select
ActiveWindow.View.Paste
Next i
End With
End Sub
Short Answer:
Is there're a short way to transfer one text range from PowerPoint A to another text range located in Powerpoint B?
I think that there's no short way to do it, but let's try something first!
Long Answer:
Note: This solution based not on your desired behaviour (since it's unclear for me and there're many and more "what if" cases), but on similar problem, so I think that it's legit. Anyway it's a good fundament to start of.
Input:
I dont know how exactly your presentations looks like, so I made a reference one (Presentation A) and a "broken" one (Presentation B). Let's take a look on them:
Presentation A (5 slides: 1x"Title slide" with 2 triangle shapes, 3x"Title and Content" slides, 1x"Section Header" slide):
Presentation B (5 slides: 1x"Title slide" missing triangle shapes, 3x"Title and Content" slides with empty/without shapes(placeholders), 1x"Blank" slide (wrong layout)):
Both presentations are in the same folder:
Desired behaviour:
Some sort of synchronisation, if we miss a shape - then create one and put desired text to it, if there's one - put desired text only (based on Presentations A's shape). There're some "what if" cases in logic:
"What if" the number of slides in each presentation isn't equal? In which order compare slides then? (In our case the number is equal, so in code we drop that part and compare slides pair by pair).
"What if" the compared slides have a different layout? (In our case difference in blank layout, so we can easily handle it, but what we should do in general?)
...and many other cases not considered in this solution
Logic:
Logic is plain and simple. The entry point to our routine is in the Presentation A, since it's an our reference file. From that point we acquire a reference to Presentation B (when opening it), and start iteration in two loops (thru each pair of slides and thru reference shapes).
If we found a "broken" (or not so, there's no check for that) shape by a reference one - we put text and some options in it or create a new one shape (or placeholder) otherwise.
Option Explicit
Sub Synch()
'define presentations
Dim ReferencePresentation As Presentation
Dim TargetPresentation As Presentation
'define reference objects
Dim ReferenceSlide As Slide
Dim ReferenceSlides As Slides
Dim ReferenceShape As Shape
'define target objects
Dim TargetSlide As Slide
Dim TargetSlides As Slides
Dim TargetShape As Shape
'define other variables
Dim i As Long
'Setting-up presentations and slide collections
Set ReferencePresentation = ActivePresentation
With ReferencePresentation
Set TargetPresentation = Presentations.Open(FileName:=.Path & "/Presentation B.pptm", _
WithWindow:=msoFalse)
Set ReferenceSlides = .Slides
End With
Set TargetSlides = TargetPresentation.Slides
'Check slide count
If ReferenceSlides.Count <> TargetSlides.Count Then
'What's a desired behaviour for this case?
'We can add slides to target presentation but it adds complexity
Debug.Print "ERROR!" & vbTab & "Reference And Target slides counts are not equal!"
Else
'"mainloop" for slides
For i = 1 To ReferenceSlides.Count
Set ReferenceSlide = ReferenceSlides(i)
Set TargetSlide = TargetSlides(i)
'Check slide layout
If ReferenceSlide.Layout <> TargetSlide.Layout Then
'What's a desired behaviourfor this case?
'We can change layout for target presentation but it adds complexity
'But let's try to change a layout too, since we have an easy case in our example!
Debug.Print "WARNING!" & vbTab & "Reference And Target slides layouts are not same!"
TargetSlide.Layout = ReferenceSlide.Layout
End If
'"innerloop" for shapes (for placeholders actually)
With ReferenceSlide
For Each ReferenceShape In .Shapes
Set TargetShape = AcquireShape(ReferenceShape, TargetSlide, True)
If TargetShape Is Nothing Then
Debug.Print "WARNING!" & vbTab & "There's no shape like " & ReferenceShape.Name
ElseIf TargetShape.HasTextFrame Then
With TargetShape.TextFrame.TextRange
'paste text
.Text = ReferenceShape.TextFrame.TextRange.Text
'and options
.Font.Size = ReferenceShape.TextFrame.TextRange.Font.Size
.Font.Name = ReferenceShape.TextFrame.TextRange.Font.Name
.Font.Color.RGB = ReferenceShape.TextFrame.TextRange.Font.Color.RGB
'...
End With
End If
Next
End With
Next
End If
'Save and close target presentation
Call TargetPresentation.Save
Call TargetPresentation.Close
End Sub
Function AcquireShape(ByRef ReferenceShape As Shape, ByRef TargetSlide As Slide, _
Optional ByVal CreateIfNotExists As Boolean) As Shape
Dim TargetShape As Shape
With ReferenceShape
'seek for existed shape
For Each TargetShape In TargetSlide.Shapes
If TargetShape.Width = .Width And TargetShape.Height = .Height And _
TargetShape.Top = .Top And TargetShape.Left = .Left And _
TargetShape.AutoShapeType = .AutoShapeType Then
Set AcquireShape = TargetShape
Exit Function
End If
Next
'create new
If CreateIfNotExists Then
If .Type = msoPlaceholder Then
Set AcquireShape = TargetSlide.Shapes.AddPlaceholder(.PlaceholderFormat.Type, .Left, .Top, .Width, .Height)
Else
Set AcquireShape = TargetSlide.Shapes.AddShape(.AutoShapeType, .Left, .Top, .Width, .Height)
End If
End If
End With
End Function
Output:
I know that it's hard to find any difference by a screenshot (it's can be even photoshoped, anyway there're a few difference for that purpose), but for a full answer, here it is:
Conclusion:
As you see, it isn't a hard task to achieve something similar to your desire, but complexity of solution depends on inputs and on "what if" cases, hence there's no short way to overcome this task in general (in my humble opinion). Cheers!
Your question has a number of different interpretations, below is my attempt to answer what I believe the question is. There are a number of stage to this solution.
1. Ensure we save the VBA we write
Firstly, we have to assume a master presentation, that is one that will hold the values to be copied into all others. This will need to be saved as a macro enabled presentation (pptm) to allow us to save our VBA. This is done via File > Save-As and while selecting the save location choose PowerPoint Macro-Enabled Presentation in the Save as type box.
2. Enable Windows scripting runtime
Within the pptm 'master' presentation that we now have, open the VBA IDE (Alt+F11). In the menu bar select Tools > References... and tick Microsoft Scripting Runtime from the list that is presented. Click OK to close the references dialog box with your tick remembered. This is needed for some error handling in the code, it checks to see if the presentation exists before trying to open it.
3. Insert the provided code
Right-click on VBAProject in the upper right area (the Project explorer) and select Insert > Module.
In the main editing area paste the below (I have added commenting to describe what is happening): -
Option Explicit
Public Sub Update()
Dim AryPresentations(4) As String
Dim LngPID As Long
Dim FSO As New FileSystemObject
Dim PP_Src As Presentation
Dim PP_Dest As Presentation
Dim Sld_Src As Slide
Dim Sld_Dest As Slide
Dim Shp_Src As Shape
Dim Shp_Dest As Shape
Dim LngFilesMissing As Long
Dim BlnWasOpen As Boolean
'If there is an error, this will handle it and stop the process
On Error GoTo ErrorHandle
'Increase the size of AryPresentations and and the paths as shown in the example below
AryPresentations(0) = "C:\Users\garye\Desktop\PP2.pptx"
AryPresentations(1) = "C:\Users\garye\Desktop\PP3.pptx"
AryPresentations(2) = "C:\Users\garye\Desktop\PP4.pptx"
AryPresentations(3) = "C:\Users\garye\Desktop\PP5.pptx"
AryPresentations(4) = "C:\Users\garye\Desktop\PP6.pptx"
'PP_Src is this, our 'master' presentation
Set PP_Src = ActivePresentation
'This loops through each item in AryPresentations
For LngPID = 0 To UBound(AryPresentations, 1)
'We rememeber if you had it open already as if you did, then we won't close it when we are done
BlnWasOpen = False
'Check all currently open presentations to see if one if the presentation we are due to update
For Each PP_Dest In PowerPoint.Presentations
If Trim(UCase(PP_Dest.FullName)) = Trim(UCase(AryPresentations(LngPID))) Then Exit For
Next
'If it was not already open, check it exists and if it does, then open in
If PP_Dest Is Nothing Then
If FSO.FileExists(AryPresentations(LngPID)) Then
Set PP_Dest = PowerPoint.Presentations.Open(AryPresentations(LngPID))
End If
Else
BlnWasOpen = True
End If
If PP_Dest Is Nothing Then
Debug.Print "File note found"
LngFilesMissing = LngFilesMissing + 1
Else
'The below connects to the slide (Sld_Src) you want to pick up from, the shape (Shp_Src) you want to pick up from and then
'places it in the slide (Sld_Dest) you want it to go to into the shape (Shp_Dest) you want it to go in to
Set Sld_Src = PP_Src.Slides(1)
Set Sld_Dest = PP_Dest.Slides(1)
Set Shp_Src = Sld_Src.Shapes(1)
Set Shp_Dest = Sld_Dest.Shapes(1)
Shp_Dest.TextFrame.TextRange.Text = Shp_Src.TextFrame.TextRange.Text
Set Shp_Dest = Nothing
Set Shp_Src = Nothing
Set Sld_Dest = Nothing
Set Sld_Src = Nothing
'Repeat the above for each piece of text to copy
'Finally save the changes
PP_Dest.Save
'Close the presentation if it was not already open
If Not BlnWasOpen Then PP_Dest.Close
End If
Next
MsgBox "Process complete. Number of missing files: " & LngFilesMissing, vbOKOnly + vbInformation, "Complete"
Exit Sub
ErrorHandle:
MsgBox "There was an error: - " & vbNewLine & vbNewLine & Err.Number & ": " & Err.Description, vbOKOnly + vbExclamation, "Error"
Err.Clear
End Sub
4. Customise code
You'll want to add the paths and location of the changes in and then it should run.

Excel VBA Copying from Various cells from various Workbooks

Need some help coding in VBA Excel.
So currently, I have 100+ tables and have to manually input all the data to each table from many separate Excel file from each region.
You can view the table image here: https://i.stack.imgur.com/ftLdE.png
My current code still depends on targeting a range of cells to copy which is not feasible considering if there is a change in the rows/columns.
Is there anyway to collectively get all the data from each region's Excel file and insert it?
Or is it possible to target a header or a table name so that it can fill in automatically?
Pardon me if the solution is so simple and have been asked before.
Thank you so much for the help.
Sub Extract()
Dim x As Workbook
Dim y As Workbook
Dim OpenSource As String
Dim OpenTarget As String
OpenSource = Application.GetOpenFilename("File Type, *.xlsm")
If OpenSource = "False" Then Exit Sub
OpenTarget = Application.GetOpenFilename("File Type, *.xlsm")
If OpenTarget = "False" Then Exit Sub
'## Open both workbooks first:
Set x = Workbooks.Open(OpenSource) 'Source File 'thisworkbook can implement here?
Set y = Workbooks.Open(OpenTarget) 'Destination File
'Now, transfer values from x to y:
y.Sheets("Data").Range("C16:N16").Value = x.Sheets("Data").Range("C19:N19").Value
y.Sheets("Data").Range("C34:N34").Value = x.Sheets("Data").Range("C37:N37").Value
y.Sheets("Data").Range("C52:N52").Value = x.Sheets("Data").Range("C55:N55").Value
y.Sheets("Data").Range("C70:N70").Value = x.Sheets("Data").Range("C73:N73").Value
y.Sheets("Data").Range("C124:N124").Value = x.Sheets("Data").Range("C127:N127").Value
y.Sheets("Data").Range("C286:N286").Value = x.Sheets("Data").Range("C289:N289").Value
y.Sheets("Data").Range("R88:AC88").Value = x.Sheets("Data").Range("R91:AC91").Value
y.Sheets("Data").Range("R106:AC106").Value = x.Sheets("Data").Range("R109:AC109").Value
y.Sheets("Data").Range("R142:AC142").Value = x.Sheets("Data").Range("R145:AC145").Value
y.Sheets("Data").Range("R160:AC160").Value = x.Sheets("Data").Range("R163:AC163").Value
y.Sheets("Data").Range("R178:AC178").Value = x.Sheets("Data").Range("R181:AC181").Value
y.Sheets("Data").Range("R196:AC196").Value = x.Sheets("Data").Range("R199:AC199").Value
y.Sheets("Data").Range("R214:AC214").Value = x.Sheets("Data").Range("R217:AC217").Value
y.Sheets("Data").Range("R232:AC232").Value = x.Sheets("Data").Range("R235:AC235").Value
y.Sheets("Data").Range("R250:AC250").Value = x.Sheets("Data").Range("R253:AC253").Value
y.Sheets("Data").Range("R268:AC268").Value = x.Sheets("Data").Range("R271:AC271").Value
y.Sheets("Data").Range("AG88:AR88").Value = x.Sheets("Data").Range("AG91:AR91").Value
y.Sheets("Data").Range("AG106:AR106").Value = x.Sheets("Data").Range("A109:AR109").Value
y.Sheets("Data").Range("AG142:AR142").Value = x.Sheets("Data").Range("AG145:AR145").Value
y.Sheets("Data").Range("AG160:AR160").Value = x.Sheets("Data").Range("AG163:AR163").Value
y.Sheets("Data").Range("AG178:AR178").Value = x.Sheets("Data").Range("AG181:AR181").Value
y.Sheets("Data").Range("AG196:AR196").Value = x.Sheets("Data").Range("AG199:AR199").Value
y.Sheets("Data").Range("AG214:AR214").Value = x.Sheets("Data").Range("AG217:AR217").Value
y.Sheets("Data").Range("AG232:AR232").Value = x.Sheets("Data").Range("AG235:AR235").Value
y.Sheets("Data").Range("AG250:AR250").Value = x.Sheets("Data").Range("AG253:AR253").Value
y.Sheets("Data").Range("AG268:AR268").Value = x.Sheets("Data").Range("AG271:AR271").Value
MsgBox ("Done")
End Sub
Sure. as long as you know the starting point, you can dynamically count and copy rows, see modification to code below:
x.Sheets("Data").Range("C16:N" & Cells(Rows.Count, 14).End(xlUp).Row).Copy Destination:=y.Sheets("Data").Range("C19")
where i have put Cells(Rows.Count,14), the 14 relates to column N.
Apply the same logic to the rest and you should be fine! let me know how this works as i have not tested it :)
I think we have the Destination and Source the wrong way around as well.
How do I put the code in reverse? E.g. The source should be from row C19:N19 of the source file and to be copied to row C14:N14 of the destination file.
Sub Extract()
Dim x As Workbook
Dim y As Workbook
Dim OpenSource As String
Dim OpenTarget As String
OpenSource = Application.GetOpenFilename("File Type, *.xlsm")
If OpenSource = "False" Then Exit Sub
OpenTarget = Application.GetOpenFilename("File Type, *.xlsm")
If OpenTarget = "False" Then Exit Sub
Set x = Workbooks.Open(OpenSource) 'Source File
Set y = Workbooks.Open(OpenTarget) 'Destination File
x.Sheets("Data").Range("C14:N" & Cells(Rows.Count, 14).End(xlUp).Row).Copy Destination:=y.Sheets("Data").Range("C19")
MsgBox ("Done")
End Sub

Getting X-Y coordinates for visio shapes using vb.net

I have recently started using vb.net for programming.
I am trying to get the X-Y coordinates of all the shapes in visio into a csv file.
I found a VBA code by Russell Christopher in which the code does exactly what I need, but it is in VBA. I tried rewriting the code in VB.net but as I am new, I do not know all of the syntax. Can anyone here please help me on that.
Here is the code that I need to convert.
Public Sub WriteTableauPointsFile()
Dim oShape As Visio.Shape
Dim oPath As Visio.Path
Dim oPoints() As Double
'Set the output file to be the same as the source file, but .CSV
oFileName = Left(ActiveDocument.FullName, Len(ActiveDocument.FullName) - 3) & "csv"
'Set the separator character
oSeparator = "|"
'If file already exists, delete it
If Dir(oFileName) <> "" Then
Kill oFileName
End If
'Open the output file and write the header line
oFile = FreeFile
Open oFileName For Append As #oFile
Print #oFile, "ShapeNo" & oSeparator & "ShapeName" & oSeparator & "PathNo" & oSeparator & "PointNo" & oSeparator & "X" & oSeparator & "Y"
'Get all the shapes on the page
ActiveWindow.SelectAll
Set oShapes = ActiveWindow.Selection
'Cycle through the shapes
For Each oShape In oShapes
'Shapes can have multiple paths
For j = 1 To oShape.Paths.Count
Set oPath = oShape.Paths(j)
'Enumerate the points in each path with 0.5 sensitivity for curves
oPath.Points 0.5, oPoints
i = 0
Do While i < UBound(oPoints)
x = Int(oPoints(i))
y = Int(oPoints(i + 1))
i = i + 2
'Write the record for each point
Print #oFile, oShape.Index; oSeparator; oShape.Text; oSeparator; j; oSeparator; i; oSeparator; x; oSeparator; y
Loop
Next j
Next
'Close the file and exit
Close #oFile
End Sub
Based on trial and error I understood that there is no such thing as "open" in vb.net. I was able to successfully convert until the "open" statement starts.
Any help will be really appreciated.
Thanks,
- Miki
I figured out the answer myself. Thought I would post it here so that it might be helpful someone looking for similar thing in future.
Dim oPoints() as Double
oPath.Points(0.5, oPoints)
i = 0
Do While i < UBound(oPoints)
x = Int(oPoints(i))
y = Int(oPoints(i + 1))
i = i + 2
Remaining portion of the code remains the same.

Run subprocedure under button -

I have this sub/macro that works if I run it as BeforeRightClick. However, I would like to change it so I can actually use my rightclick and put the macro on a button instead.
So I have tried to change the name from BeforeRightClick.
I have tried with both a normal form button and an ActiveX.
All this + some more code is posted under Sheet1 and not modules
Dim tabA As Variant, tabM As Variant
Dim adrA As String, adrM As String
' Set columns (MDS tabel) where data should be copied to (APFtabel)
'Post to
'P1-6 divisions ' Name adress, etc
Const APFtabel = "P1;P2;P3;P4;P5;P6;E9;E10;E13;E14;E23;N9;N10;N11;N12;N20"
'Load data from
Const MDStabel = "N;O;P;Q;R;S;H;Y;Z;AB;W;AF;T;D;AA;V;"
Dim APF As Workbook
' APFilNavn is the name of the AP form
Const APFilNavn = "APForm_macro_pdf - test.xlsm"
' Const APFsti As String = ActiveWorkbook.Path
Const APFarkNavn = "Disposition of new supplier"
' APsti is the path of the folder
Dim sysXls As Object, APFSti As String
Dim ræk As Integer
Private Sub CommandButton1_Click()
APFormRun
End Sub
' Here I changed it from BeforeRightClick
Private Sub APFormRun(ByVal Target As Range, Cancel As Boolean)
Dim cc As Object
If Target.Column = 8 Then
APFSti = ActiveWorkbook.Path & "\"
If Target.Address <> "" Then
For Each cc In Selection.Rows
Cancel = True
ræk = cc.Row
Set sysXls = ActiveWorkbook
åbnAPF
overførData
opretFiler
APF.Save
APF.Close
Set APF = Nothing
Set sysXls = Nothing
Next cc
End If
End If
End Sub
Private Sub overførData()
Dim ix As Integer
tabA = Split(APFtabel, ";")
tabM = Split(MDStabel, ";")
Application.ScreenUpdating = False
For ix = 0 To UBound(tabM) - 1
If Trim(tabM(ix)) <> "" Then
adrM = tabM(ix) & ræk
If tabA(ix) <> "" Then
adrA = tabA(ix)
End If
With APF.ActiveSheet
.Range(adrA).Value = sysXls.Sheets(1).Range(adrM).Value
End With
End If
Next ix
End Sub
Private Sub opretFiler()
' Here I run some other macro exporting the files to Excel and PDF
btnExcel
btnExportPDF
End Sub
if you put this code in Sheet1, then to access it from a button you need to define its name (in the button) as Sheet1.APFormRun (and I think you need to make it Public).
If you move the sub and everything it calls to a Module (after doing an Insert->Module), then you do not need the Excel Object Name prefix.
A very detailed write-up about scoping is at the link below. Scroll down to the "Placement of Macros/ Sub procedures in appropriate Modules" section: http://www.globaliconnect.com/excel/index.php?option=com_content&view=article&id=162:excel-vba-calling-sub-procedures-a-functions-placement-in-modules&catid=79&Itemid=475
In your code above, I had to comment out all the subs you didn't include just to get it to compile for debugging.
To make a sub accessible to the Macros button or to "Assign Macro..." you have to make it Public
Also to make a sub accessible, it cannot have any passed parameters.
So you will have to remove the passed parameters from the Public Sub APFormRun() definition
Therefore you will have to re-write the initial portion of APFormRun ... currently your APFormRun relies upon getting a passed parameter (Target) of the selected cell that you right-clicked upon. When you press a button, there is no cell that you are right-clicking upon. It is not a cell-identifying Excel event. You will have to obtain the selected cell via the Selection excel object. There are a lot of StackOverflow answers on how to do that.

Customized CATIA V5 Macro to browse Excel coordinate file & plot points

Please bear with my limited knowledge in CATIA VBA.
I am having some difficulties in customize a CATIA V5 macro to browse for Excel coordinate points and plot it in CATIA, all with a click on the customized CATIA icon.
I got an Excel file with many XYZ coordinates, let call it ExcelP1
(The excel file has no scripts/Macro in it), I would like to develop
a macro in CATIA to read & plot points from ExcelP1.
Currently i have another "Excel file with macro" to browse the
ExcelP1, and plot the points in CATIA. But i need to open and run
the "Excel file with macro" first to initiate CATIA. The scripts are
as below (i didn't develop this)
Public Filename As String
Private Sub Browse_Click()
'Open File
Mainform.Hide
Filename = Application.GetOpenFilename("Excel Files (*.xls), *.xls")
If Filename <> "False" Then
Application.Visible = False
filenamebox.Value = Filename
Else
Application.Visible = False
Filename = filenamebox.Value
End If
Mainform.Show
End Sub
Private Sub ClearButton_Click()
Mainform.Hide
ActiveWorkbook.Close (False)
Application.Visible = False
End Sub
Private Sub OKButton_Click()
'Set Up Message Labels
Title = "Information Message"
'Check for Entered Values
If filenamebox.Value <> "" Then
Workbooks.Open Filename:=Filename
Application.Visible = False
'Start CATIA and add an Open body to the document
Start_CATIA
Mainform.Hide
'Read Point Data from file and create point in CATIA
i = 2
Do Until Worksheets("Sheet1").Range("a" & i).Value = ""
x = Worksheets("Sheet1").Range("a" & i).Value
y = Worksheets("Sheet1").Range("b" & i).Value
z = Worksheets("Sheet1").Range("c" & i).Value
Create_Point
i = i + 1
Loop
i = i - 2
MsgBox i & " Points Created in New Part", , Title
Else
MsgBox "Enter a Filename", , Title
End If
ActiveWorkbook.Close (False)
Mainform.Show
End Sub
Private Sub UserForm_Initialize()
If Worksheets("Filepath_Location").Range("a1").Value <> "" Then
Filename = Worksheets("Filepath_Location").Range("a1").Value
filenamebox.Value = Filename
End If
End Sub
What do I need to add/modify in order for the scripts to run in CATIA?
The first thing you need to do after you start Catia and get the application is to create a new Part in which you will be adding the points.
Dim MyPartDocument As PartDocument
Dim MyPart As Part
Dim PointGeoSet As HybridBody
Set MyPartDocument = CATIA.Documents.Add("Part")
Set MyPart = MyPartDocument.Part
Set PointGeoSet = MyPart.HybridBodies.Add()
PointGeoSet.Name = "MyPoints"
The next thing is to create the point from the excel data by using a function like this. I like to create a wrapper, but you can rewrite this anyway you want:
Sub CreateXYZPoint(TargetPart As Part, TargetGeometricalSet As HybridBody, _
Xmm As Double, Ymm As Double, Zmm As Double, _
PointCount As String)
Dim HSFactory As HybridShapeFactory
Dim NewPoint As Point
'get the factory
Set HSFactory = TargetPart.HybridShapeFactory
'create the point with the factory
Set NewPoint = HSFactory.AddNewPointCoord(Xmm, Ymm, Zmm)
'Append the point to the geometrical set
TargetGeometricalSet.AppendHybridShape NewPoint
'rename the point
NewPoint.Name = "Point." & PointCount
End Sub
You Would call
CreateZYXPoint MyPart, PointGeoSet,x,y,z,cstr(i) in your loop
Finally, at the end of your loop, you will want to update the part so call:
MyPart.Update
It is much faster to do a single update at the end of your program than to update after each point is created.
This should get you started. Remember, Catia uses Millimeters as it's base internal units. Therefore, your spreadsheet match units or you must do a unit conversion before calling CreateXYZPoint...or However you want to accomplish that.
Let me know if this works for you.
Edit: Here's a link to the code put together with your code above. You need to make sure you excel code is working, but where I inserted the Catia code is correct:
http://pastebin.com/vxFcPw52