Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Pers Makro bearbeiten.

Betrifft: Pers Makro bearbeiten. von: chris b
Geschrieben am: 16.01.2008 07:24:04

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


  

Betrifft: AW: Pers Makro bearbeiten. von: Rudi Maintaire
Geschrieben am: 16.01.2008 09:07:09

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


  

Betrifft: AW: Pers Makro bearbeiten.offen von: chris b
Geschrieben am: 16.01.2008 09:27:36

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


  

Betrifft: AW: Pers Makro bearbeiten.offen von: Rudi Maintaire
Geschrieben am: 16.01.2008 09:39:18

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


  

Betrifft: AW: Pers Makro bearbeiten.offen von: chris b
Geschrieben am: 16.01.2008 09:51:18

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


  

Betrifft: AW: Pers Makro bearbeiten.offen von: Rudi Maintaire
Geschrieben am: 16.01.2008 10:19:49

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


  

Betrifft: AW: Pers Makro bearbeiten.offen von: chris b
Geschrieben am: 16.01.2008 10:39:30

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


  

Betrifft: AW: doch noch nichT :( Rudi bitte noch einmal von: chris b
Geschrieben am: 16.01.2008 10:56:08

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 !


  

Betrifft: AW: doch noch nichT :( Rudi bitte noch einmal von: chris b
Geschrieben am: 16.01.2008 11:25:33

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


  

Betrifft: AW: doch noch nichT :( Rudi bitte noch einmal von: Rudi Maintaire
Geschrieben am: 16.01.2008 11:43:20

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


  

Betrifft: AW: doch noch nichT :( Rudi bitte noch einmal von: chris b
Geschrieben am: 16.01.2008 15:12:52

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




  

Betrifft: AW: Pers Makro bearbeiten. von: chris b
Geschrieben am: 16.01.2008 09:40:52

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