Thema: Pers Makro bearbeiten.

Hallo guten morgen VBA Experten,
ich suche eine Lösung.habe bis jetzt alleine schon geschafft das mir ein Makro 2 Icons in die Menüleiste einfügt.Und diese dann 2 verschiedene Makros aufruft.
Jetzt möchte ich aber das die beiden Makros (hoch und querformat) in die persönliche Makromappe eingefügt werden die Automatisch beim Excelstart gestartet wird.
Also als ein neues Modul.
Und wenn diese noch nicht vorhanden ist auf dem Computer soll Sie erst neu erstellt werden und dann die beiden Makros eingefügt werden.
Würde mich sehr über eure Hilfe freuen.
Danke
Option Explicit

Public Sub CreateMenueButton()
Dim myCommandBar As CommandBar
Dim myCommandBarButton As CommandBarButton
Set myCommandBar = Application.CommandBars("Worksheet Menu Bar")
'Querformat
Set myCommandBarButton = myCommandBar.Controls.Add(Type:=msoControlButton, _
Before:=myCommandBar.Controls.Count + 1, Temporary:=True)
With myCommandBarButton
.BeginGroup = True
.Caption = "Querformat"
.FaceId = 38
.OnAction = "quer"
.Style = msoButtonIconAndCaption
.TooltipText = "Seite Querformat einrichten"
.Tag = "Quer"
End With
'Hochformat
Set myCommandBarButton = myCommandBar.Controls.Add(Type:=msoControlButton, _
Before:=myCommandBar.Controls.Count + 1, Temporary:=True)
With myCommandBarButton
.BeginGroup = True
.Caption = "Hochformat"
.FaceId = 39
.OnAction = "hoch"
.Style = msoButtonIconAndCaption
.TooltipText = "Seite Hochformat einrichten"
.Tag = "Quer"
End With
Set myCommandBar = Nothing
Set myCommandBarButton = Nothing
Set myCommandBar = Nothing
Set myCommandBarButton = Nothing
End Sub

Public Sub querformat()
Application.ScreenUpdating = False
Cells.Select
ActiveSheet.PageSetup.PrintArea = ""
ActiveSheet.PageSetup.PrintArea = Selection.Address
With ActiveSheet.PageSetup
'       .LeftHeader = ""
'       .CenterHeader = ""
'       .RightHeader = ""
.LeftFooter = "&D"
'       .CenterFooter = ""
.RightFooter = "&Z&F"
.LeftMargin = Application.InchesToPoints(0.590551181102362)
.RightMargin = Application.InchesToPoints(0.393700787401575)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
'      .CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
Range("A1").Select
Application.ScreenUpdating = False
ActiveWindow.SelectedSheets.PrintPreview
End Sub

Public Sub hochformat()
Application.ScreenUpdating = False
Cells.Select
ActiveSheet.PageSetup.PrintArea = ""
ActiveSheet.PageSetup.PrintArea = Selection.Address
With ActiveSheet.PageSetup
'       .LeftHeader = ""
'       .CenterHeader = ""
'       .RightHeader = ""
.LeftFooter = "&D"
'       .CenterFooter = ""
.RightFooter = "&Z&F"
.LeftMargin = Application.InchesToPoints(0.590551181102362)
.RightMargin = Application.InchesToPoints(0.393700787401575)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
'     .PrintQuality = 600
.CenterHorizontally = True
'      .CenterVertically = False
.Orientation = xlPortrait
'    .Draft = False
'     .PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
'     .Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
'     .PrintErrors = xlPrintErrorsDisplayed
End With
Range("A1").Select
Application.ScreenUpdating = False
ActiveWindow.SelectedSheets.PrintPreview
End Sub

Hallo,
ich würde die Mappe mit den Makros als Addin speichern und dann über den Add-Ins-Manager einbinden.
Gruß
Rudi
Eine Kuh macht Muh, viele Kühe machen Mühe

Das geht in meinem Fall nicht.
Kann jemand die frage anders beantworten.
Danke dir trotzdem für den versuch !

Hallo,
nun, dann halt nicht.
Ist denn sichergestellt, dass auf allen Rechnern bei denen du das machen willst, der Haken bei 'Zugriff auf Visual-Basic-Projekt vertrauen' drin ist? Sonst kannst du keinen Code per Code erstellen.
Gruß
Rudi
Eine Kuh macht Muh, viele Kühe machen Mühe

ja genau das ist das Problem.
Ist es natürlich nicht :(
Aber mit addins kenne ich mich noch nicht so dut aus.
Also wie mann die installiert usw..
Habe jetzt einen code mit dem ich herausbekomme wo die addins installiert sind bereits.
Das habe ich herausfinden wollen weil ich ja meine xls.datei auxch in diesen ordner kopieren lassen will als xla aber auch da könnte ein problem entstehen zum beispiel wenn der user selbst addins eingebunden hat die auf einem anderen laufwerk liegen also der standartaddin Ordner dann würde meine datei auch nicht richtig kopiert werden ..
Gibt es einen Lösung

Hallo,
das ist recht einfach:

Sub prcInstallAddIn()
Dim myADDIN As AddIn
On Error Resume Next
Set myADDIN = AddIns("test")
On Error GoTo 0
If myADDIN Is Nothing Then
Application.DisplayAlerts = False
AddIns.Add ("p:\test.xla")  'wo liegt das Addin? Pfad anpassen
Application.DisplayAlerts = True
End If
AddIns("test").Installed = True
End Sub

Das Addin kann auf einem beliebigen Netzlaufwerk leigen.
Gruß
Rudi
Eine Kuh macht Muh, viele Kühe machen Mühe

Super.
Vielen Dank !!!
bekomm ich jetzt schon hin !

Hallo Rudi,
bekomme es nichtzum laufen :((
ich versuche vergeblich die geöffnete xls.datei zu speichern und als addin zu aktivieren :(
Klappt nicht.

Sub wo_ist_pers_anlegen()
Dim AI As AddIn
Dim Copypfad As String
Dim myADDIN As AddIn
On Error Resume Next
Set myADDIN = AddIns("Ansichten.xla")
On Error GoTo 0
For Each AI In Application.AddIns
If InStr(UCase(AI.Name), "SOLVER") Then
Copypfad = AI.Path
Exit For
Else
End If
Next
If Copypfad = "" Then
On Error Resume Next
Copypfad = Workbooks("PERSONL.XLS").Path
If Copypfad = "" Then
Copypfad = Application.Path
Else
'Speicherpfad für addin zu pers xls hinzufügen
End If
End If
On Error GoTo 0
If Right(Copypfad, Len(Copypfad)) = "\" Then
Else
Copypfad = Copypfad & "\"
End If
'ActiveWorkbook.SaveCopyAs Copypfad & "Ansichten.xla"
'AddIns.Add (Copypfad & "Ansicht_Anpassen.xla")  'wo liegt das Addin? Pfad anpassen
If myADDIN Is Nothing Then
Application.DisplayAlerts = False
AddIns.Add ("C:\Program Files\Microsoft Office\OFFICE11\Library\SOLVER\Ansichten.xla")  ' _
wo liegt das Addin? Pfad anpassen
Application.DisplayAlerts = True
End If
AddIns("test").Installed = True
AddIns.Add ("c:\test.xla"), copyfile:=True
AddIns("MeinAddIn").Installed = True
'AddIns("test.xla").Installed = True
Set a = AddIns("Solver Add-In")
If a.Installed = True Then
MsgBox "The Solver add-in is installed"
Else
MsgBox "The Solver add-in is not installed"
End If
AddIns.Add("test.xla").Installed = True
AddIns("C:\Documents and Settings\byc3ba\Desktop\hoch quer.xla").Installed = True
End Sub

Bitte um weitere Hilfe !

iss addin auf true
habe es hinbekommen.
Danke noch einmal !

Hallo,
schön.
Die Pfadbestimmung kannst du dir sparen. Das weiß Excel selbst, wo die Addins liegen.
Ergo einfach so:

Sub prcInstallAddIn()
Dim myADDIN As AddIn
On Error Resume Next
Set myADDIN = AddIns("Ansichten")
On Error GoTo 0
If myADDIN Is Nothing Then
AddIns.Add ("C:\Program Files\Microsoft Office\OFFICE11\Library\SOLVER\Ansichten.xla"),  _
True
End If
AddIns("Ansichten").Installed = True
End Sub

Wenn das Addin noch nicht im Addin-Manager vorhanden ist, wird es von dem angegebenen Ort (kann auch ein Netzlaufwerk sein) in das Addin-Verzeichnis des Benutzer kopiert und installiert.
Gruß
Rudi
Eine Kuh macht Muh, viele Kühe machen Mühe

hallo Rudi,
noch einmal vielen Dank !
Aber ich habe noch ein problem.
Ich habe eine xls datei die ich ausführe dann in den speicherort kopiere in dem die addins liegen.
Dann erstelle ich 2 icons im menü die immer jeweils ein makro aus dem addin starten sollten.
Funktioniert aber nicht weil ich pfad wenn ich auch ansicht bearbeiten gehe im pfad von den Makros der dateinahme der exceldatei steht.
Kannst du mir vielleicht helfen ?
Wäre klasse hast mir auch schon super geholfen.
Vielen Dank und hier noch meine bisherigen codes
'---------------------- Makro modul 1
Option Explicit
Sub install_addIn()
Dim AI As AddIn
Dim Copypfad As String
Dim Newwb As Workbook
'Pfad erstellen wohin addin kopiert wird
For Each AI In Application.AddIns
If InStr(UCase(AI.Name), "SOLVER") Then
Copypfad = AI.Path
Exit For
Else
End If
Next
If Copypfad = "" Then
On Error Resume Next
Copypfad = Workbooks("PERSONL.XLS").Path
If Copypfad = "" Then
Copypfad = Application.Path
Else
'Speicherpfad für addin zu pers xls hinzufügen
End If
End If
On Error GoTo 0
If Right(Copypfad, 1) = "\" Then
Else
Copypfad = Copypfad & "\"
End If
If Dir(Copypfad & "Ansichten.xla") = "" Then
ActiveWorkbook.SaveCopyAs Copypfad & "Ansichten.xla"
Else
'datei vorhanden
End If
Set Newwb = Workbooks.Open(Copypfad & "Ansichten.xla")
On Error Resume Next
Newwb.IsAddin = False
Call CreateMenueButton
Newwb.ActiveSheet.Shapes("Button 1").Delete
Newwb.IsAddin = True
Newwb.Close True
On Error GoTo 0
AddIns.Add(Copypfad & "Ansichten.xla").Installed = True
ThisWorkbook.ChangeFileAccess xlReadOnly
Kill ThisWorkbook.FullName
ThisWorkbook.Close False
End Sub

'------------- Makro modul 2
Option Explicit

Public Sub CreateMenueButton()
Dim myCommandBar As CommandBar
Dim myCommandBarButton As CommandBarButton
Set myCommandBar = Application.CommandBars("Worksheet Menu Bar")
On Error Resume Next
Application.CommandBars("Worksheet Menu Bar").Controls("Querformat").Delete
Application.CommandBars("Worksheet Menu Bar").Controls("Hochformat").Delete
On Error GoTo 0
'Querformat
Set myCommandBarButton = myCommandBar.Controls.Add(Type:=msoControlButton, _
Before:=myCommandBar.Controls.Count + 1, Temporary:=False)
With myCommandBarButton
.BeginGroup = True
.Caption = "Querformat"
.FaceId = 38
.OnAction = "!querformat"
'   .Style = msoButtonIconAndCaption
'   .TooltipText = "Seite Querformat einrichten"
'   .Tag = "Quer"
End With
'Hochformat
Set myCommandBarButton = myCommandBar.Controls.Add(Type:=msoControlButton, _
Before:=myCommandBar.Controls.Count + 1, Temporary:=False)
With myCommandBarButton
.BeginGroup = True
.Caption = "Hochformat"
.FaceId = 39
.OnAction = "!hochformat"
'.Style = msoButtonIconAndCaption
'.TooltipText = "Seite Hochformat einrichten"
'.Tag = "Quer"
End With
Set myCommandBar = Nothing
Set myCommandBarButton = Nothing
Set myCommandBar = Nothing
Set myCommandBarButton = Nothing
End Sub

Public Sub querformat()
End Sub

Public Sub hochformat()
End Sub

Hallo ich habe mir noch einmal gedanken gemacht.
Vielleicht würde es doch klappen.Ich benötige nur noch die möglcihkeit dies also das Installieren des Addins Automatisch erfolgen zu lassen weil sonst der benutzer vielleicht Probleme bekommt und es nicht schafft.
Also so stele ich mir das vor.
ich habe eine Datei "install.xla"
wenn jemand die datei öffnet wird sie automatisch in das addin verzeichniss kopiert das irgendwo auf c: ist.
und die 2 Icons werden erstellt.
Nur wie mache ich das ?
geht das ?
Danke noch einmal