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

Bitte verwende Codetags das man das lesen kann. Vorallem wenns soviel ist.. versuch es vll. so zu darzustellen, dass man keine halbe Stunde braucht um es nachvollziehen zu können.

Guten Morgen. Das tut mir leid.

Mir ist bei Excel und Co wirklich lieber, wenn ich eine Excel-Mappe runterladen kann, wo der Fehler drin ist. Nachbauen macht, zumindest mir, keinen Spaß.

Liebe Forenmitglieder,

ich bitte euch wirklich anständig um Hilfe.

Lieber Hilfesuchender,

wir bitten dich wirklich anständig um eine Basis, die man bearbeiten kann.

puu.sh/kF3ih/36287c0e28.png
benutz bitte das und beschreib ausführlich, deine frage/dein fehler...

und google, vor JEDEM post!
Laufzeitfehler '13': Typen unverträglich erst seit Excel2010
kp, ob das dein fehler behebt...