Hallo,
ich bräuchte dringend Hilfe. Ich bekomme die Fehlermeldung "laufzeitfehler 13 typen unverträglich".
Beim Debuggen erhalte ich an folgenden tellen einen Fehler:
Sub showSettingDialog()
settingsForm.Show
End Sub
und hier:
Private Sub UserForm_Initialize()
topPos.Value = GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="topPos")
leftPos.Value = GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="leftPos")
sizeOfBullet.Value = GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="sizeOfBullet")
spaceBetweenBullets.Value = GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="spaceBetweenBullets")
wraparound.Value = GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="wraparound")
wraparoundlimit.Value = GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="wraparoundlimit")
Debug.Print GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="OptionHorizontal")
Debug.Print CBool(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="OptionHorizontal"))
Der Code lautet:
'Option Explicit
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
Private Declare PtrSafe Function UpdateWindow Lib "user32" (ByVal hWnd As Long) As Long
Declare PtrSafe Function ChooseColor Lib "comdlg32.dll" _
Alias "ChooseColorA" ( _
lpcc As CHOOSECOLOR_TYPE) As Long
Private Type CHOOSECOLOR_TYPE
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As Long
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
' Anwender kann alle Farben wählen
Private Const CC_ANYCOLOR = &H100
' Nachrichten können "abgefangen" werden
Private Const CC_ENABLEHOOK = &H10
' Dialogbox Template
Private Const CC_ENABLETEMPLATE = &H20
' Benutzt Template, ignoriert aber den Template-Namen
Private Const CC_ENABLETEMPLATEHANDLE = &H40
' Vollauswahl aller Farben anzeigen
Private Const CC_FULLOPEN = &H2
' Deaktiviert den Button zum Öffnen der Dialogbox-Erweiterung
Private Const CC_PREVENTFULLOPEN = &H4
' Vorgabe einer Standard-Farbe
Private Const CC_RGBINIT = &H1
' Hilfe-Button anzeigen
Private Const CC_SHOWHELP = &H8
' nur Grundfarben auswählbar
Private Const CC_SOLIDCOLOR = &H80
Sub Example_ScreenUpdating()
ScreenUpdating(FindWindowHandle(Application)) = True 'or False
End Sub
Property Let ScreenUpdating(Optional ByVal hWnd As Long, ByVal State As Boolean)
If Not State Then
LockWindowUpdate hWnd
Else
LockWindowUpdate False
UpdateWindow hWnd
End If
End Property
Function FindWindowHandle(ByVal App As Object, Optional ByVal Caption As String) As Long
If App Is Nothing Then
FindWindowHandle = FindWindow(vbNullString, Caption)
Else
On Error Resume Next
Select Case App.Name
Case "Microsoft Access"
'Caption = App.Name
FindWindowHandle = FindWindow("OMAIN", Caption)
Case "Microsoft Excel"
'Caption = App.Caption
FindWindowHandle = FindWindow("XLMAIN", Caption)
Case "Microsoft PowerPoint"
Select Case Val(Application.Version)
Case 8
FindWindowHandle = FindWindow("PP97FrameClass", Caption)
Case 9 To 12
'Caption = App.Caption & " - [" & App.ActiveWindow.Caption & "]"
FindWindowHandle = FindWindow("PP" & Val(Application.Version) & "FrameClass", _
Caption)
Case Else
'Caption = App.Caption
FindWindowHandle = FindWindow("PPTFrameClass", Caption)
End Select
Case "Microsoft Word"
'Caption = App.ActiveWindow.Caption & " - " & App.Caption
FindWindowHandle = FindWindow("OPUSAPP", Caption)
Case "Outlook"
'Caption = Application.ActiveExplorer.Caption
FindWindowHandle = FindWindow("rctrl_renwnd32", Caption)
Case Else
'Userform
'Caption = App.Caption
If Val(Application.Version) >= 9 Then
FindWindowHandle = FindWindow("ThunderDFrame", Caption)
Else
FindWindowHandle = FindWindow("ThunderXFrame", Caption)
End If
End Select
End If
End Function
Sub Auto_Open()
Dim oToolbar As CommandBar
Dim oButton As CommandBarButton
Dim MyToolbar As String
' Give the toolbar a name
MyToolbar = "Progress Addin"
On Error Resume Next
' so that it doesn't stop on the next line if the toolbar's already there
' Create the toolbar; PowerPoint will error if it already exists
Set oToolbar = CommandBars.Add(Name:=MyToolbar, _
Position:=msoBarFloating, temporary:=True)
If Err.Number <> 0 Then
' The toolbar's already there, so we have nothing to do
Exit Sub
End If
On Error GoTo ErrorHandler
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Add Progress Bar"
'Tooltip text when mouse if placed over button
.Caption = "AddDetailedProgressBar"
'Text if Text in Icon is chosen
.OnAction = "AddDetailedProgressBar"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 35
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Remove Progress Bar"
'Tooltip text when mouse if placed over button
.Caption = "RemoveDetailedProgressBar"
'Text if Text in Icon is chosen
.OnAction = "RemoveDetailedProgressBar"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 67
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Add Section"
'Tooltip text when mouse if placed over button
.Caption = "AddSection"
'Text if Text in Icon is chosen
.OnAction = "AddSection"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 137
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Remove Section"
'Tooltip text when mouse if placed over button
.Caption = "RemoveSection"
'Text if Text in Icon is chosen
.OnAction = "RemoveSection"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 138
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Add Ignore Slide"
'Tooltip text when mouse if placed over button
.Caption = "AddIgnoreSlide"
'Text if Text in Icon is chosen
.OnAction = "AddIgnoreSlide"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 214
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Remove Ignore Slide"
'Tooltip text when mouse if placed over button
.Caption = "RemoveIgnoreSlide"
'Text if Text in Icon is chosen
.OnAction = "RemoveIgnoreSlide"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 213
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Clear Structure"
'Tooltip text when mouse if placed over button
.Caption = "Delete old structure"
'Text if Text in Icon is chosen
.OnAction = "ClearOldStructure"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 215
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Show Settings Dialog"
'Tooltip text when mouse if placed over button
.Caption = "Show Settings"
'Text if Text in Icon is chosen
.OnAction = "showSettingDialog"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 44
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Show Info Dialog"
'Tooltip text when mouse if placed over button
.Caption = "Show Info"
'Text if Text in Icon is chosen
.OnAction = "showInfoDialog"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 124
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Repeat the above for as many more buttons as you need to add
' Be sure to change the .OnAction property at least for each new button
' You can set the toolbar position and visibility here if you like
' By default, it'll be visible when created
oToolbar.top = 150
oToolbar.left = 150
oToolbar.Visible = True
NormalExit:
Exit Sub ' so it doesn't go on to run the errorhandler code
ErrorHandler:
'Just in case there is an error
MsgBox Err.Number & vbCrLf & Err.Description
Resume NormalExit:
End Sub
Sub showSettingDialog()
settingsForm.Show
End Sub
Sub showInfoDialog()
helpForm.Show
End Sub
Sub AddSection()
On Error Resume Next
Dim presentation As Object
Dim s As PowerPoint.Shape
presentation = Application.ActivePresentation
Set s = Application.ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, 10, 10, 10, 10)
s.Name = "section"
s.Visible = False
Application.ActiveWindow.Selection.SlideRange.Comments.Add 0, 0, "", "", "Section"
End Sub
Sub AddIgnoreSlide()
On Error Resume Next
Dim presentation As Object
Dim s As PowerPoint.Shape
presentation = Application.ActivePresentation
Application.ActiveWindow.Selection.SlideRange.NotesPage.Tags.Add "Ignore", "True"
Set s = Application.ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, 10, 10, 10, 10)
s.Name = "ignore"
s.Visible = False
Application.ActiveWindow.Selection.SlideRange.Comments.Add 0, 0, "", "", "Ignore"
End Sub
Sub RemoveSection()
On Error Resume Next
Dim currentSlide As slide
'Dim currSlideNum As Integer
'currSlideNum = ActiveWindow.View.Slide.SlideIndex
'Set currentSlide = ActiveWindow.Selection.SlideRange.Item(currSlideNum)
'Set currentSlide = ActivePresentation.Slides(currSlideNum)
Set currentSlide = ActivePresentation.Slides(ActiveWindow.View.slide.Name)
With currentSlide
.Shapes("section").Delete
.Comments.Item(1).Delete
End With
End Sub
Sub RemoveIgnoreSlide()
On Error Resume Next
Dim currentSlide As slide
Set currentSlide = ActivePresentation.Slides(ActiveWindow.View.slide.Name)
With currentSlide
.Shapes("ignore").Delete
.Comments.Item(1).Delete
End With
End Sub
Sub AddDetailedProgressBar()
ScreenUpdating(FindWindowHandle(Application)) = False
RemoveDetailedProgressBar
On Error Resume Next
Dim presentation As PowerPoint.presentation
Dim s As PowerPoint.Shape
Set presentation = Application.ActivePresentation
Dim counter As Integer: counter = 0
Dim slide As slide
Dim X As Integer: X = 0
Dim initialTop As Integer: initialTop = 0
Dim initialLeft As Integer: initialLeft = 0
Dim bulletCounter As Integer: bulletCounter = 0
Dim Count As Integer: Count = 0
Dim sectionCounter As Integer: sectionCounter = 0
Dim slidesPerSection As Integer: slidesPerSection = 0
Dim numberOfSections As Integer: numberOfSections = 0
Dim sectionLength As Variant: sectionLength = 0
Dim mySections() As Integer
Dim sectionSlides() As Integer
ReDim Preserve mySections(0 To 1)
ReDim Preserve sectionSlides(0 To 1)
' Determine structure of slide set
With presentation
For X = 1 To .Slides.Count
Dim notHidden As Boolean
notHidden = Not .Slides(X).SlideShowTransition.Hidden
Dim notIgnored As Boolean
If .Slides(X).NotesPage.Tags.Count = 0 Then
notIgnored = True
Else
notIgnored = False
End If
If notHidden And notIgnored Then
'get slide numbers
ReDim Preserve sectionSlides(0 To (UBound(sectionSlides) + 1))
sectionSlides(counter) = .Slides(X).slideNumber
counter = counter + 1
If IsNull(.Slides(X).Shapes("section")) Then
mySections(sectionCounter) = mySections(sectionCounter) + 1
Else
ReDim Preserve mySections(0 To (UBound(mySections) + 1))
sectionCounter = sectionCounter + 1
mySections(sectionCounter) = 1
End If
End If
Next X
End With
'load from settings
Dim left As Integer: left = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="leftPos"))
Dim top As Integer: top = presentation.PageSetup.SlideHeight - CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="topPos"))
Dim sizeOfBullet As Integer: sizeOfBullet = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="sizeOfBullet"))
Dim spaceBetweenBullets As Integer: spaceBetweenBullets = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="spaceBetweenBullets"))
Dim maxleft As Integer: maxleft = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="wraparound"))
Dim wraparoundoffset As Integer: wraparoundoffset = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="wraparoundlimit"))
Dim colorRed As Integer: colorRed = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="colorRed"))
Dim colorYellow As Integer: colorYellow = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="colorYellow"))
Dim colorBlue As Integer: colorBlue = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="colorBlue"))
Dim vertical As Boolean: vertical = CBool(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="OptionVertical"))
'init if fields are null
If IsNull(left) Then
left = 20
End If
'init if fields are null
If IsNull(maxleft) Then
left = 500
End If
If IsNull(top) Then
top = 50
End If
If IsNull(sizeOfBullet) Then
sizeOfBullet = 6
End If
If IsNull(spaceBetweenBullets) Then
spaceBetweenBullets = 8
End If
'init if fields are null
If IsNull(wraparoundoffset) Then
wraparoundoffset = 2 * sizeOfBullet
End If
initialLeft = left
initialTop = top
With presentation
Dim currentSlideNumber As Integer: currentSlideNumber = 0
For Each slide In .Slides
'bullet counter needed to do wrap arround
bulletCounter = 0
left = initialLeft
top = initialTop
Dim slideNumber As Integer: slideNumber = 0
'Dim notHidden As Boolean: notHidden = Slide.SlideShowTransition.Hidden = Microsoft.Office.Core.MsoTriState.msoFalse
notHidden = Not slide.SlideShowTransition.Hidden
'Dim notIgnored As Boolean
notIgnored = True
If slide.NotesPage.Tags.Count = 0 Then
notIgnored = True
Else
notIgnored = False
End If
If notHidden And notIgnored Then
For Each sectionLength In mySections
If vertical Then
If top > maxleft Then
left = left + wraparoundoffset
top = initialLeft
End If
Else
If left > maxleft Then
top = top + wraparoundoffset
left = initialLeft
End If
End If
For Count = 1 To sectionLength
bulletCounter = bulletCounter + 1
Set s = slide.Shapes.AddShape(msoShapeOval, left, top, sizeOfBullet, sizeOfBullet)
s.Name = "PB_" & CStr(slideNumber)
If currentSlideNumber = slideNumber Then
s.Fill.ForeColor.RGB = RGB(colorRed, colorYellow, colorBlue)
s.Line.ForeColor.RGB = RGB(colorRed, colorYellow, colorBlue)
Else
s.Fill.ForeColor.RGB = RGB(220, 220, 220)
s.Line.ForeColor.RGB = RGB(150, 150, 150)
End If
With s.ActionSettings(ppMouseClick)
.Action = ppActionNamedSlideShow
With .Hyperlink
'.Address = Me.Application.ActivePresentation.FullName
.SubAddress = CStr(sectionSlides(slideNumber))
.Follow
End With
End With
slideNumber = slideNumber + 1
If vertical Then
top = top + spaceBetweenBullets
Else
left = left + spaceBetweenBullets
End If
Next Count
If vertical Then
top = top + spaceBetweenBullets
Else
left = left + spaceBetweenBullets
End If
Next sectionLength
'slide.Shapes("PB").Delete()
currentSlideNumber = currentSlideNumber + 1
End If
Next
End With
ScreenUpdating(FindWindowHandle(Application)) = True
End Sub
Sub RemoveDetailedProgressBar()
Dim presentation As PowerPoint.presentation
Set presentation = Application.ActivePresentation
Dim X As Integer: X = 0
Dim slide As slide
With presentation
For Each slide In .Slides
For X = 0 To slide.Shapes.Count
On Error Resume Next
'Debug.Print slide.Shapes.Count
Debug.Print slide.Shapes(X).Name
slide.Shapes("PB_" & CStr(X)).Delete
Next
Next
End With
End Sub
Sub ClearOldStructure()
Dim presentation As PowerPoint.presentation
Set presentation = Application.ActivePresentation
Dim slide As slide
With presentation
For Each slide In .Slides
On Error Resume Next
With slide
.Shapes("ignore").Delete
.Comments.Item(1).Delete
.Shapes("section").Delete
.Comments.Item(1).Delete
End With
For X = 0 To slide.Shapes.Count
On Error Resume Next
slide.Shapes("PB_" & CStr(X)).Delete
Next
Next
End With
End Sub
Sub ShowFaceIDs()
Dim NewToolbar As CommandBar
Dim NewButton As CommandBarButton
Dim i As Integer, IDStart As Integer, IDStop As Integer
' Delete existing FaceIds toolbar if it exists
On Error Resume Next
Application.CommandBars("FaceIds").Delete
On Error GoTo 0
' Add an empty toolbar
Set NewToolbar = Application.CommandBars.Add _
(Name:="FaceIds", temporary:=True)
NewToolbar.Visible = True
' Change the following values to see different FaceIDs
IDStart = 1
IDStop = 250
For i = IDStart To IDStop
'Set NewButton = NewToolbar.Add(Type:=msoControlButton, Id:=2950)
Set NewButton = NewToolbar.Controls.Add(Type:=msoControlButton)
NewButton.FaceId = i
NewButton.Caption = "FaceID = " & i
Next i
NewToolbar.Width = 600
End Sub
Vielen Dank im Voraus
ich bräuchte dringend Hilfe. Ich bekomme die Fehlermeldung "laufzeitfehler 13 typen unverträglich".
Beim Debuggen erhalte ich an folgenden tellen einen Fehler:
Sub showSettingDialog()
settingsForm.Show
End Sub
und hier:
Private Sub UserForm_Initialize()
topPos.Value = GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="topPos")
leftPos.Value = GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="leftPos")
sizeOfBullet.Value = GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="sizeOfBullet")
spaceBetweenBullets.Value = GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="spaceBetweenBullets")
wraparound.Value = GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="wraparound")
wraparoundlimit.Value = GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="wraparoundlimit")
Debug.Print GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="OptionHorizontal")
Debug.Print CBool(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="OptionHorizontal"))
Der Code lautet:
'Option Explicit
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
Private Declare PtrSafe Function UpdateWindow Lib "user32" (ByVal hWnd As Long) As Long
Declare PtrSafe Function ChooseColor Lib "comdlg32.dll" _
Alias "ChooseColorA" ( _
lpcc As CHOOSECOLOR_TYPE) As Long
Private Type CHOOSECOLOR_TYPE
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As Long
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
' Anwender kann alle Farben wählen
Private Const CC_ANYCOLOR = &H100
' Nachrichten können "abgefangen" werden
Private Const CC_ENABLEHOOK = &H10
' Dialogbox Template
Private Const CC_ENABLETEMPLATE = &H20
' Benutzt Template, ignoriert aber den Template-Namen
Private Const CC_ENABLETEMPLATEHANDLE = &H40
' Vollauswahl aller Farben anzeigen
Private Const CC_FULLOPEN = &H2
' Deaktiviert den Button zum Öffnen der Dialogbox-Erweiterung
Private Const CC_PREVENTFULLOPEN = &H4
' Vorgabe einer Standard-Farbe
Private Const CC_RGBINIT = &H1
' Hilfe-Button anzeigen
Private Const CC_SHOWHELP = &H8
' nur Grundfarben auswählbar
Private Const CC_SOLIDCOLOR = &H80
Sub Example_ScreenUpdating()
ScreenUpdating(FindWindowHandle(Application)) = True 'or False
End Sub
Property Let ScreenUpdating(Optional ByVal hWnd As Long, ByVal State As Boolean)
If Not State Then
LockWindowUpdate hWnd
Else
LockWindowUpdate False
UpdateWindow hWnd
End If
End Property
Function FindWindowHandle(ByVal App As Object, Optional ByVal Caption As String) As Long
If App Is Nothing Then
FindWindowHandle = FindWindow(vbNullString, Caption)
Else
On Error Resume Next
Select Case App.Name
Case "Microsoft Access"
'Caption = App.Name
FindWindowHandle = FindWindow("OMAIN", Caption)
Case "Microsoft Excel"
'Caption = App.Caption
FindWindowHandle = FindWindow("XLMAIN", Caption)
Case "Microsoft PowerPoint"
Select Case Val(Application.Version)
Case 8
FindWindowHandle = FindWindow("PP97FrameClass", Caption)
Case 9 To 12
'Caption = App.Caption & " - [" & App.ActiveWindow.Caption & "]"
FindWindowHandle = FindWindow("PP" & Val(Application.Version) & "FrameClass", _
Caption)
Case Else
'Caption = App.Caption
FindWindowHandle = FindWindow("PPTFrameClass", Caption)
End Select
Case "Microsoft Word"
'Caption = App.ActiveWindow.Caption & " - " & App.Caption
FindWindowHandle = FindWindow("OPUSAPP", Caption)
Case "Outlook"
'Caption = Application.ActiveExplorer.Caption
FindWindowHandle = FindWindow("rctrl_renwnd32", Caption)
Case Else
'Userform
'Caption = App.Caption
If Val(Application.Version) >= 9 Then
FindWindowHandle = FindWindow("ThunderDFrame", Caption)
Else
FindWindowHandle = FindWindow("ThunderXFrame", Caption)
End If
End Select
End If
End Function
Sub Auto_Open()
Dim oToolbar As CommandBar
Dim oButton As CommandBarButton
Dim MyToolbar As String
' Give the toolbar a name
MyToolbar = "Progress Addin"
On Error Resume Next
' so that it doesn't stop on the next line if the toolbar's already there
' Create the toolbar; PowerPoint will error if it already exists
Set oToolbar = CommandBars.Add(Name:=MyToolbar, _
Position:=msoBarFloating, temporary:=True)
If Err.Number <> 0 Then
' The toolbar's already there, so we have nothing to do
Exit Sub
End If
On Error GoTo ErrorHandler
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Add Progress Bar"
'Tooltip text when mouse if placed over button
.Caption = "AddDetailedProgressBar"
'Text if Text in Icon is chosen
.OnAction = "AddDetailedProgressBar"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 35
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Remove Progress Bar"
'Tooltip text when mouse if placed over button
.Caption = "RemoveDetailedProgressBar"
'Text if Text in Icon is chosen
.OnAction = "RemoveDetailedProgressBar"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 67
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Add Section"
'Tooltip text when mouse if placed over button
.Caption = "AddSection"
'Text if Text in Icon is chosen
.OnAction = "AddSection"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 137
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Remove Section"
'Tooltip text when mouse if placed over button
.Caption = "RemoveSection"
'Text if Text in Icon is chosen
.OnAction = "RemoveSection"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 138
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Add Ignore Slide"
'Tooltip text when mouse if placed over button
.Caption = "AddIgnoreSlide"
'Text if Text in Icon is chosen
.OnAction = "AddIgnoreSlide"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 214
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Remove Ignore Slide"
'Tooltip text when mouse if placed over button
.Caption = "RemoveIgnoreSlide"
'Text if Text in Icon is chosen
.OnAction = "RemoveIgnoreSlide"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 213
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Clear Structure"
'Tooltip text when mouse if placed over button
.Caption = "Delete old structure"
'Text if Text in Icon is chosen
.OnAction = "ClearOldStructure"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 215
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Show Settings Dialog"
'Tooltip text when mouse if placed over button
.Caption = "Show Settings"
'Text if Text in Icon is chosen
.OnAction = "showSettingDialog"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 44
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Show Info Dialog"
'Tooltip text when mouse if placed over button
.Caption = "Show Info"
'Text if Text in Icon is chosen
.OnAction = "showInfoDialog"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 124
'52 is my favorite pig;
' chooses icon #52 from the available Office icons
End With
' Repeat the above for as many more buttons as you need to add
' Be sure to change the .OnAction property at least for each new button
' You can set the toolbar position and visibility here if you like
' By default, it'll be visible when created
oToolbar.top = 150
oToolbar.left = 150
oToolbar.Visible = True
NormalExit:
Exit Sub ' so it doesn't go on to run the errorhandler code
ErrorHandler:
'Just in case there is an error
MsgBox Err.Number & vbCrLf & Err.Description
Resume NormalExit:
End Sub
Sub showSettingDialog()
settingsForm.Show
End Sub
Sub showInfoDialog()
helpForm.Show
End Sub
Sub AddSection()
On Error Resume Next
Dim presentation As Object
Dim s As PowerPoint.Shape
presentation = Application.ActivePresentation
Set s = Application.ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, 10, 10, 10, 10)
s.Name = "section"
s.Visible = False
Application.ActiveWindow.Selection.SlideRange.Comments.Add 0, 0, "", "", "Section"
End Sub
Sub AddIgnoreSlide()
On Error Resume Next
Dim presentation As Object
Dim s As PowerPoint.Shape
presentation = Application.ActivePresentation
Application.ActiveWindow.Selection.SlideRange.NotesPage.Tags.Add "Ignore", "True"
Set s = Application.ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, 10, 10, 10, 10)
s.Name = "ignore"
s.Visible = False
Application.ActiveWindow.Selection.SlideRange.Comments.Add 0, 0, "", "", "Ignore"
End Sub
Sub RemoveSection()
On Error Resume Next
Dim currentSlide As slide
'Dim currSlideNum As Integer
'currSlideNum = ActiveWindow.View.Slide.SlideIndex
'Set currentSlide = ActiveWindow.Selection.SlideRange.Item(currSlideNum)
'Set currentSlide = ActivePresentation.Slides(currSlideNum)
Set currentSlide = ActivePresentation.Slides(ActiveWindow.View.slide.Name)
With currentSlide
.Shapes("section").Delete
.Comments.Item(1).Delete
End With
End Sub
Sub RemoveIgnoreSlide()
On Error Resume Next
Dim currentSlide As slide
Set currentSlide = ActivePresentation.Slides(ActiveWindow.View.slide.Name)
With currentSlide
.Shapes("ignore").Delete
.Comments.Item(1).Delete
End With
End Sub
Sub AddDetailedProgressBar()
ScreenUpdating(FindWindowHandle(Application)) = False
RemoveDetailedProgressBar
On Error Resume Next
Dim presentation As PowerPoint.presentation
Dim s As PowerPoint.Shape
Set presentation = Application.ActivePresentation
Dim counter As Integer: counter = 0
Dim slide As slide
Dim X As Integer: X = 0
Dim initialTop As Integer: initialTop = 0
Dim initialLeft As Integer: initialLeft = 0
Dim bulletCounter As Integer: bulletCounter = 0
Dim Count As Integer: Count = 0
Dim sectionCounter As Integer: sectionCounter = 0
Dim slidesPerSection As Integer: slidesPerSection = 0
Dim numberOfSections As Integer: numberOfSections = 0
Dim sectionLength As Variant: sectionLength = 0
Dim mySections() As Integer
Dim sectionSlides() As Integer
ReDim Preserve mySections(0 To 1)
ReDim Preserve sectionSlides(0 To 1)
' Determine structure of slide set
With presentation
For X = 1 To .Slides.Count
Dim notHidden As Boolean
notHidden = Not .Slides(X).SlideShowTransition.Hidden
Dim notIgnored As Boolean
If .Slides(X).NotesPage.Tags.Count = 0 Then
notIgnored = True
Else
notIgnored = False
End If
If notHidden And notIgnored Then
'get slide numbers
ReDim Preserve sectionSlides(0 To (UBound(sectionSlides) + 1))
sectionSlides(counter) = .Slides(X).slideNumber
counter = counter + 1
If IsNull(.Slides(X).Shapes("section")) Then
mySections(sectionCounter) = mySections(sectionCounter) + 1
Else
ReDim Preserve mySections(0 To (UBound(mySections) + 1))
sectionCounter = sectionCounter + 1
mySections(sectionCounter) = 1
End If
End If
Next X
End With
'load from settings
Dim left As Integer: left = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="leftPos"))
Dim top As Integer: top = presentation.PageSetup.SlideHeight - CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="topPos"))
Dim sizeOfBullet As Integer: sizeOfBullet = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="sizeOfBullet"))
Dim spaceBetweenBullets As Integer: spaceBetweenBullets = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="spaceBetweenBullets"))
Dim maxleft As Integer: maxleft = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="wraparound"))
Dim wraparoundoffset As Integer: wraparoundoffset = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="wraparoundlimit"))
Dim colorRed As Integer: colorRed = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="colorRed"))
Dim colorYellow As Integer: colorYellow = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="colorYellow"))
Dim colorBlue As Integer: colorBlue = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="colorBlue"))
Dim vertical As Boolean: vertical = CBool(GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="OptionVertical"))
'init if fields are null
If IsNull(left) Then
left = 20
End If
'init if fields are null
If IsNull(maxleft) Then
left = 500
End If
If IsNull(top) Then
top = 50
End If
If IsNull(sizeOfBullet) Then
sizeOfBullet = 6
End If
If IsNull(spaceBetweenBullets) Then
spaceBetweenBullets = 8
End If
'init if fields are null
If IsNull(wraparoundoffset) Then
wraparoundoffset = 2 * sizeOfBullet
End If
initialLeft = left
initialTop = top
With presentation
Dim currentSlideNumber As Integer: currentSlideNumber = 0
For Each slide In .Slides
'bullet counter needed to do wrap arround
bulletCounter = 0
left = initialLeft
top = initialTop
Dim slideNumber As Integer: slideNumber = 0
'Dim notHidden As Boolean: notHidden = Slide.SlideShowTransition.Hidden = Microsoft.Office.Core.MsoTriState.msoFalse
notHidden = Not slide.SlideShowTransition.Hidden
'Dim notIgnored As Boolean
notIgnored = True
If slide.NotesPage.Tags.Count = 0 Then
notIgnored = True
Else
notIgnored = False
End If
If notHidden And notIgnored Then
For Each sectionLength In mySections
If vertical Then
If top > maxleft Then
left = left + wraparoundoffset
top = initialLeft
End If
Else
If left > maxleft Then
top = top + wraparoundoffset
left = initialLeft
End If
End If
For Count = 1 To sectionLength
bulletCounter = bulletCounter + 1
Set s = slide.Shapes.AddShape(msoShapeOval, left, top, sizeOfBullet, sizeOfBullet)
s.Name = "PB_" & CStr(slideNumber)
If currentSlideNumber = slideNumber Then
s.Fill.ForeColor.RGB = RGB(colorRed, colorYellow, colorBlue)
s.Line.ForeColor.RGB = RGB(colorRed, colorYellow, colorBlue)
Else
s.Fill.ForeColor.RGB = RGB(220, 220, 220)
s.Line.ForeColor.RGB = RGB(150, 150, 150)
End If
With s.ActionSettings(ppMouseClick)
.Action = ppActionNamedSlideShow
With .Hyperlink
'.Address = Me.Application.ActivePresentation.FullName
.SubAddress = CStr(sectionSlides(slideNumber))
.Follow
End With
End With
slideNumber = slideNumber + 1
If vertical Then
top = top + spaceBetweenBullets
Else
left = left + spaceBetweenBullets
End If
Next Count
If vertical Then
top = top + spaceBetweenBullets
Else
left = left + spaceBetweenBullets
End If
Next sectionLength
'slide.Shapes("PB").Delete()
currentSlideNumber = currentSlideNumber + 1
End If
Next
End With
ScreenUpdating(FindWindowHandle(Application)) = True
End Sub
Sub RemoveDetailedProgressBar()
Dim presentation As PowerPoint.presentation
Set presentation = Application.ActivePresentation
Dim X As Integer: X = 0
Dim slide As slide
With presentation
For Each slide In .Slides
For X = 0 To slide.Shapes.Count
On Error Resume Next
'Debug.Print slide.Shapes.Count
Debug.Print slide.Shapes(X).Name
slide.Shapes("PB_" & CStr(X)).Delete
Next
Next
End With
End Sub
Sub ClearOldStructure()
Dim presentation As PowerPoint.presentation
Set presentation = Application.ActivePresentation
Dim slide As slide
With presentation
For Each slide In .Slides
On Error Resume Next
With slide
.Shapes("ignore").Delete
.Comments.Item(1).Delete
.Shapes("section").Delete
.Comments.Item(1).Delete
End With
For X = 0 To slide.Shapes.Count
On Error Resume Next
slide.Shapes("PB_" & CStr(X)).Delete
Next
Next
End With
End Sub
Sub ShowFaceIDs()
Dim NewToolbar As CommandBar
Dim NewButton As CommandBarButton
Dim i As Integer, IDStart As Integer, IDStop As Integer
' Delete existing FaceIds toolbar if it exists
On Error Resume Next
Application.CommandBars("FaceIds").Delete
On Error GoTo 0
' Add an empty toolbar
Set NewToolbar = Application.CommandBars.Add _
(Name:="FaceIds", temporary:=True)
NewToolbar.Visible = True
' Change the following values to see different FaceIDs
IDStart = 1
IDStop = 250
For i = IDStart To IDStop
'Set NewButton = NewToolbar.Add(Type:=msoControlButton, Id:=2950)
Set NewButton = NewToolbar.Controls.Add(Type:=msoControlButton)
NewButton.FaceId = i
NewButton.Caption = "FaceID = " & i
Next i
NewToolbar.Width = 600
End Sub
Vielen Dank im Voraus