Office Forum

VBA-Bericht öffnen durch die Funktion ersetzen

Code: Alles auswählen

Public Sub MyOpenReport( _
        sReportName As String, _
        vView As AcView, _
        Optional sFilterName as String, _
        Optional sWhereCondition As String, _
        OptionalvWindowMode As AcWindowMode = acDialog, _
        sOpenArgs As String)

    DoCmd.ShowToolbar "Ribbon", acToolbarYes
    DoCmd.OpenReport sReportName, weitere, benötigte, Parameter
'! acDialog ist wichtig damit der Code angehalten wird, solange der Bericht
'geöffnet ist.
'evtl. muss hier noch ein "DoEvents" eingefügt werden
    DoCmd.ShowToolbar "Ribbon", acToolbarNo
End Sub


Prinzessin87 hat geschrieben:Jedoch hab ich noch das Problem das beim Bericht die Menüleiste gebraucht wird bezüglich drucken? Kann man hier nur das Drucken aktivieren oder muss die ganze Leiste her?

Code: Alles auswählen

'DoCmd.ShowToolbar "Ribbon", acToolbarNo

Code: Alles auswählen

Private m_DaoDB As DAO.Database
Public Property Get CurrentDbC() As DAO.Database
If (m_DaoDB Is Nothing) Then
Set m_DaoDB = CurrentDb
End If
Set CurrentDbC = m_DaoDB
End Property

Code: Alles auswählen

Function StartEigenschaften()
If IsACCDE Then
MsgBox ("Bin eine ACCDE Datei")

   Dim intX As Integer
   Const DB_Text As Long = 10
   Const DB_Boolean As Long = 1

   '//Anwendungstitel
   AendernEigenschaft "AppTitle", DB_Text, "Text"
   '// MS Access-Titelleiste aktualisieren
   Application.RefreshTitleBar
   '//Datenbankfenster ausblenden
   AendernEigenschaft "StartupShowDBWindow", DB_Boolean, False
   '//Menü- und Symbolleistenänderungen zulassen
   '//AendernEigenschaft "AllowToolbarChanges", DB_Boolean, False
   '//Codeansicht nach Fehler zulassen
   '//AendernEigenschaft "AllowBreakIntoCode", DB_Boolean, False

   '//Frage-Symbolleiste ausblenden
   Application.CommandBars.DisableAskAQuestionDropdown = True
   '//Fenster in Taskleiste nicht anzeigen
   Application.SetOption ("ShowWindowsInTaskbar"), False

Call DB_Sperren
Else
MsgBox ("bin die Vollversion")
Call DB_oeffnen
End If
End Function

Function AendernEigenschaft(strName As String, varTyp As Variant, varWert As Variant) As Integer

   Dim DBs As Object, prp As Variant
   Const conPropNotFoundError = 3270

   Set DBs = CurrentDb
   On Error GoTo AendernEigenschaft_Fehler

   DBs.Properties(strName) = varWert
   AendernEigenschaft = True

AendernEigenschaft_Ende:
   Exit Function

AendernEigenschaft_Fehler:
   If Err = conPropNotFoundError Then
      Set prp = DBs.CreateProperty(strName, varTyp, varWert)
      DBs.Properties.Append prp
      Resume
   Else
      AendernEigenschaft = False
      Resume AendernEigenschaft_Ende
   End If
End Function


Public Sub DB_oeffnen()
On Error Resume Next

   '//Menü- und Symbolleistenänderungen zulassen
   AendernEigenschaft "AllowToolbarChanges", DB_Boolean, True
   '//Codeansicht nach Fehler zulassen
   AendernEigenschaft "AllowBreakIntoCode", dbBoolean, True
   '//Spezialtasten (ALT+F1 (F11), STRG+F11, STRG+UNTBR und STRG+G) zulassen
   AendernEigenschaft "AllowSpecialKeys", dbBoolean, True
   '//Shifttaste zulassen
   AendernEigenschaft "AllowBypassKey", dbBoolean, True
End Sub

Public Sub DB_Sperren()
On Error Resume Next

   '//Menü- und Symbolleistenänderungen sperren
   AendernEigenschaft "AllowToolbarChanges", DB_Boolean, False
   '//Codeansicht nach Fehler sperren
   AendernEigenschaft "AllowBreakIntoCode", dbBoolean, False
   '//Spezialtasten (ALT+F1 (F11), STRG+F11, STRG+UNTBR und STRG+G) sperren
   AendernEigenschaft "AllowSpecialKeys", dbBoolean, False
   '//Shifttaste sperren
   AendernEigenschaft "AllowBypassKey", dbBoolean, False

End Sub

'Funktion, um zu prüfen ob accde: Abfrage in Formular frmStart (Form_Open)
Public Function IsACCDE() As Boolean
On Error GoTo Err_IsACCDE
Dim StrProp As String
'
On Error Resume Next
    StrProp = CurrentDb.Properties("MDE")
    IsACCDE = (Err.Number = 0) And (StrProp = "T") 'true bei ACCDE
Exit_IsACCDE:
    On Error Resume Next
'    Resume Next
    Exit Function
Err_IsACCDE:
    MsgBox Err.Description
    Resume Exit_IsACCDE
End Function

'//Menü- und Symbolleistenänderungen zulassen
AendernEigenschaft "AllowToolbarChanges", DB_Boolean, True

'//Codeansicht nach Fehler zulassen
AendernEigenschaft "AllowBreakIntoCode", dbBoolean, True

Code: Alles auswählen

Private Sub Form_Open(Cancel As Integer)
DB_Sperren
End Sub

Code: Alles auswählen

Option Compare Database
Option Explicit

Private m_DaoDB As DAO.Database

Public Function IsACCDE() As Boolean
On Error GoTo Err_IsACCDE
Dim StrProp As String
'
On Error Resume Next
    StrProp = CurrentDb.Properties("MDE")
    IsACCDE = (Err.Number = 0) And (StrProp = "T") 'true bei ACCDE
Exit_IsACCDE:
    On Error Resume Next
'    Resume Next
    Exit Function
Err_IsACCDE:
    MsgBox Err.Description
    Resume Exit_IsACCDE
End Function

Public Sub DB_Sperren()

    If IsACCDE Then
        MsgBox ("Bin eine ACCDE Datei")
        DoCmd.ShowToolbar "Ribbon", acToolbarNo
        CurrentDbC.Properties("ShowDocumentTabs") = False
        CurrentDbC.Properties("AllowSpecialKeys") = False
        CurrentDbC.Properties("AllowDatasheetSchema") = False
        CurrentDbC.Properties("StartUpShowDBWindow") = False
        CurrentDbC.Properties("DesignWithData") = False
        CurrentDbC.Properties("AllowFullMenus") = False
        CurrentDbC.Properties("AllowBypassKey") = False
       
    Else
        MsgBox ("Bin eine Vollversion")
        DoCmd.ShowToolbar "Ribbon", acToolbarYes
        CurrentDbC.Properties("ShowDocumentTabs") = True
        CurrentDbC.Properties("AllowSpecialKeys") = True
        CurrentDbC.Properties("AllowDatasheetSchema") = True
        CurrentDbC.Properties("StartUpShowDBWindow") = True
        CurrentDbC.Properties("DesignWithData") = True
        CurrentDbC.Properties("AllowFullMenus") = True
        CurrentDbC.Properties("AllowBypassKey") = True
   
    End If

End Sub


Public Property Get CurrentDbC() As DAO.Database
If (m_DaoDB Is Nothing) Then
Set m_DaoDB = CurrentDb
End If
Set CurrentDbC = m_DaoDB
End Property

Code: Alles auswählen

Sub DB_Sperren(janein As Boolean)

ChangeProp "StartupShowDBWindow", dbBoolean, Not janein
ChangeProp "StartupShowStatusBar", db, Not janein
ChangeProp "AllowBuiltinToolbars", dbBoolean, Not janein
ChangeProp "AllowFullMenus", dbBoolean, Not janein
ChangeProp "AllowBreakIntoCode", dbBoolean, Not janein
ChangeProp "AllowSpecialKeys", dbBoolean, Not janein
ChangeProp "AllowSpecialKeys", dbBoolean, Not janein
ChangeProp "AllowBypassKey", dbBoolean, Not janein
ChangeProp "AllowToolbarChanges", dbBoolean, Not janein

'ChangeProp "StartupShowDBWindow" , dbBoolean, Not janein
'ChangeProp "StartupShowStatusBar" , dbBoolean, Not janein
'ChangeProp "AllowBuiltinToolbars" , dbBoolean, Not janein
'ChangeProp "AllowFullMenus" , dbBoolean, Not janein
'ChangeProp "AllowBreakIntoCode" , dbBoolean, Not janein
'ChangeProp "AllowSpecialKeys" , dbBoolean, Not janein
'ChangeProp "AllowBypassKey" , dbBoolean, Not janein

End Sub
 
Function ChangeProp(strEigenschaftenname As String, varEigenschaftentyp As Variant, varEigenschaftenwert As Variant) As Boolean
Dim DBs As DAO.Database, prp As DAO.Property
Const conPropNotFoundError = 3270

On Error GoTo ChangeProp_Fehler

Set DBs = CurrentDb
    DBs.Properties(strEigenschaftenname) = varEigenschaftenwert
    ChangeProp = True

ChangeProp_Ende:
    Exit Function

ChangeProp_Fehler:

If Err = conPropNotFoundError Then
        Set prp = DBs.CreateProperty(strEigenschaftenname, _
            varEigenschaftentyp, varEigenschaftenwert)
        DBs.Properties.Append prp
        Resume Next
    Else
        ChangeProp = False
        Resume ChangeProp_Ende
    End If
End Function

Code: Alles auswählen

Sub ....
DB_Sperren true
End Sub

Code: Alles auswählen

'Funktion, um zu prüfen ob accde: Abfrage in Formular frmStart (Form_Open)
Public Function IsACCDE() As Boolean
On Error GoTo Err_IsACCDE
Dim StrProp As String
'
On Error Resume Next
    StrProp = CurrentDb.Properties("MDE")
    IsACCDE = (Err.Number = 0) And (StrProp = "T") 'true bei ACCDE
Exit_IsACCDE:
    On Error Resume Next
'    Resume Next
    Exit Function
Err_IsACCDE:
    MsgBox Err.Description
    Resume Exit_IsACCDE
End Function

Code: Alles auswählen

Private m_DaoDB As DAO.Database
Public Property Get CurrentDbC() As DAO.Database
If (m_DaoDB Is Nothing) Then
Set m_DaoDB = CurrentDb
End If
Set CurrentDbC = m_DaoDB
End Property

Code: Alles auswählen

Set dbsNorthwind = OpenDatabase("Northwind.mdb")

Code: Alles auswählen

' Set the Archive property to True.
   SetProperty dbsNorthwind, "Archive", True

Code: Alles auswählen

  dbsTemp.Properties("strName") = booTemp

Code: Alles auswählen

Sub CreatePropertyX()

   Dim dbsNorthwind As Database
   Dim prpLoop As Property

   Set dbsNorthwind = OpenDatabase("Northwind.mdb")

   ' Set the Archive property to True.
   SetProperty dbsNorthwind, "Archive", True
   
   With dbsNorthwind
      Debug.Print "Properties of " & .Name
     
      ' Enumerate Properties collection of the Northwind
      ' database.
      For Each prpLoop In .Properties
         If prpLoop <> "" Then Debug.Print "  " & _
            prpLoop.Name & " = " & prpLoop
      Next prpLoop

      ' Delete the new property since this is a
      ' demonstration.
      .Properties.Delete "Archive"

      .Close
   End With

End Sub

Sub SetProperty(dbsTemp As Database, strName As String, _
   booTemp As Boolean)

   Dim prpNew As Property
   Dim errLoop As Error

   ' Attempt to set the specified property.
   On Error GoTo Err_Property
   dbsTemp.Properties("strName") = booTemp
   On Error GoTo 0

   Exit Sub

Err_Property:

   ' Error 3270 means that the property was not found.
   If DBEngine.Errors(0).Number = 3270 Then
      ' Create property, set its value, and append it to the
      ' Properties collection.
      Set prpNew = dbsTemp.CreateProperty(strName, _
         dbBoolean, booTemp)
      dbsTemp.Properties.Append prpNew
      Resume Next
   Else
      ' If different error has occurred, display message.
      For Each errLoop In DBEngine.Errors
         MsgBox "Error number: " & errLoop.Number & vbCr & _
            errLoop.Description
      Next errLoop
      End
   End If

End Sub