Solved: Custom Userform

[TrippyTom]

Is there a way to put graphics in a userform?

I want to make something like the attached graphic.

[TrippyTom]

nevermind, I figured it out. :blush

Wish me luck on the actual code! hehe... I think I might be asking for trouble.

[MOS MASTER]

Good luck! :D

[TrippyTom]

I'm actually getting somewhere with this project! Wow, it's amazing what one can do with knowledge of the library. It's just sad the the help file for it is completely inadequate.

I'm hoping to do this without running back to here for help ;)
So far so good.

:thumb

[MOS MASTER]

Hey that's great well done!

Working things out on your own is a great motivator! :thumb

[TrippyTom]

I'm stumped on the main part of my routine. Here's how I thought I was going to handle the split:

If splitting vertically:
1) cut shape in place
2) figure out the newWidth the multiple objects would be (i've done that)
3) Paste object in place (setting the newWidth)

for i = 1 to shapePref (# of shapes) - 1
4) figure out newPosition
5) paste another shape into the newPosition
next i

So I guess my questions are....
A) How do I paste an object with specifying a different width?
B) How do I paste an object relative to the previous object (instead of the top left of the screen)?

Here's the code I have so far. I hope i makes some sense. :(
This is the main procedure that calls the one below it (the 2nd one is what i'm having trouble with)

Sub mySplice()
On Error GoTo Nirvana
If Not ActiveWindow.Selection.ShapeRange.HasTable Then
If ActiveWindow.Selection.ShapeRange.Count = 1 Then
frm_Splice.Show
ElseIf ActiveWindow.Selection.ShapeRange.Count <> 1 Then
Exit Sub
End If
ElseIf ActiveWindow.Selection.ShapeRange.HasTable Then
MsgBox ("I'm sorry, this isn't meant to work with tables.")
Exit Sub
End If

If splitPref = "vertical" Then
Call myShapeWidth
Exit Sub
ElseIf splitPref = "horizontal" Then
Call myShapeHeight
Exit Sub
End If
Nirvana:
MsgBox ("Please select a shape first.")
End Sub



Sub myShapeWidth()
Dim myShape As Variant
Dim myWidth As Single
Dim newWidth As Single
Dim i As Integer
Dim mySlide As Integer
Dim newPosition As Single
On Error GoTo Nirvana
mySlide = ActiveWindow.View.Slide.SlideIndex
If ActiveWindow.Selection.ShapeRange.Count = 1 Then
ScreenUpdating = False
Set myShape = ActiveWindow.Selection.ShapeRange
With myShape
myWidth = ActiveWindow.Selection.ShapeRange.Width 'returns pixels (multiply by 72 to get inches value)

'shapePref = # of shapes (this is a public variable)
'shapePref = space between shapes (this is a public variable)
newWidth = myWidth / shapePref - (spacePref * (shapePref - 1)) ' this is the magic formula

MsgBox ("Object width: " & myWidth & vbLf & "# of shapes: " & shapePref & vbLf & "Space between: " & spacePref & vbLf & "New width: " & newWidth)
myShape.Cut 'cut shape (which by default, remembers the original location)

For i = 1 To shapePref 'shapePref = # of shapes user wants
If i = 1 Then
'ActivePresentation.Slides(mySlide).Shapes.Paste 'paste first shape in same place
'mySlide.Shapes.AddShape Type:=msoShapeRectangle, Left:=50, Top:=50, Width:=100, Height:=200
'[ ??? ]
ElseIf i > 1 Then
ActivePresentation.Slides(mySlide).Shapes.Paste 'paste shape
' set the newWidth on the pasted shape
newPosition = newWidth + spacePref 'move shape to new spot

Set myShape = ActiveWindow.Selection.ShapeRange
myShape.Copy 'copy the next shape for the next loop
End If
Next i
End With
ScreenUpdating = True
ElseIf ActiveWindow.Selection.ShapeRange.Count <> 1 Then
MsgBox ("I'm sorry, this only works with a single shape.")
End If

Nirvana:
End Sub


p.s. - Could this not be marked as solved? (or should I start a different topic)

[Killian]

Continued here:
http://www.vbaexpress.com/forum/showthread.php?t=8821