• 
• 
• 

• Faktbase
• über uns
• produkte
• FAQ
• kontakt
• impressum

Quellcode Beispiele zum Download

Adressdaten nach Word übergeben!

'===================================================================
'  FUNKTION:   CopyToWord()
'
'  AUFGABE:    Übergabe Adressdaten nach WinWord
'=============================================================

Function CopyToWord()
  
   Dim CRLF As String

   CRLF = Chr(13) & Chr(10)
  
   Set WordObj = CreateObject("Word.Basic")
   WordObj.AnwAktivieren "Microsoft Word", True
   WordObj.DateiNeu
   WordObj.DateiSeiteEinrichten , , "5,2 cm"
   WordObj.Einfügen Forms!Adressen![Firma 1] & CRLF

   If Not IsNull(Forms!Adressen![Firma 2]) Then WordObj.Einfügen Forms!Adressen![Firma 2] & CRLF
    
   If Not IsNull(Forms!Adressen![Abteilung]) Then WordObj.Einfügen "Abt. " & Forms!Adressen![Abteilung] & CRLF

   Select Case Forms!Adressen![Geschlecht]
     Case "-"
     Case "F"
         WordObj.Einfügen "Frau "
     Case "H"
         WordObj.Einfügen "Herr "
   End Select

   If Not IsNull(Forms!Adressen![Titel]) Then WordObj.Einfügen Forms!Adressen![Titel] & " "
  
   If Not IsNull(Forms!Adressen![Vorname]) Then WordObj.Einfügen Forms!Adressen![Vorname] & " "
  
   If Not IsNull(Forms!Adressen![Nachname]) Then WordObj.Einfügen Forms!Adressen![Nachname] & CRLF
  
   If Not IsNull(Forms!Adressen![Straße]) Then WordObj.Einfügen Forms!Adressen![Straße] & CRLF & CRLF
  
   If Not IsNull(Forms!Adressen![Land]) Then
     WordObj.Unterstrichen 1
     WordObj.Fett 1
     WordObj.Schriftgrad 12
     WordObj.Einfügen Forms!Adressen![Land] & "-" & Forms!Adressen![Plz] & " " & Forms!Adressen![Stadt]
     WordObj.Unterstrichen 0
     WordObj.Fett 0
     WordObj.Schriftgrad 10
     WordObj.Einfügen CRLF
   End If
  
   WordObj.Einfügen CRLF & CRLF & CRLF & CRLF & CRLF & CRLF
  
   WordObj.Einfügen DLookup("[UserCity]", "[SystemInfo]") & ", den " & Format(Now, "dd.mm.yyyy")
   WordObj.BeginnZeile
   WordObj.MarkierungErweitern
   WordObj.EndeZeile
   WordObj.AbsatzRechts
   WordObj.MarkierungVerkleinern
   WordObj.EndeZeile
   WordObj.Einfügen CRLF & CRLF & CRLF & CRLF & CRLF & CRLF
   WordObj.AbsatzLinks

   WordObj.Fett 1
   WordObj.Einfügen "Betreff:"
   WordObj.Fett 0
  
   If Not IsNull(Forms!Adressen!Anrede) Then
     WordObj.Einfügen CRLF & CRLF & CRLF & CRLF
     WordObj.Einfügen Forms!Adressen!Anrede
     WordObj.Einfügen CRLF & CRLF
   End If

   WordObj.BearbeitenAllesMarkieren
   WordObj.Kapitälchen 0
   WordObj.MarkierungVerkleinern
   WordObj.EndeDokument

End Function
 

Datensatzsprung

'===================================================================
'  FUNKTION:   Datensatzsprung
'
'  AUFGABE:    Springt im Datensatz zu den jeweiligen Datensätzen
'                      (zurück, vorwärts, Zum ersten, zum letzten)
'=============================================================
Function Datensatzsprung(Direction As Integer)
  

 Dim MyDyna As Dynaset, RetValue As Integer, AktiverButton As Control
  
   On Error Resume Next

   If Forms!Adressen.Dirty Then
     Forms!Adressen![Geändert am] = CLng(Now)
     Forms!Adressen![GeäVon] = CurrentUser()
   End If
  
   Select Case Direction
  
     Case 0 ' Vorwärts blättern angewählt.
         If CurrentRecord < TotalNumOfRec Then
           DoCmd.GoToRecord A_FORM, "Adressen", A_NEXT
           CurrentRecord = CurrentRecord + 1
         Else
           RetValue = Sicherheitsabfrage(4, ER_MESSAGE)
         End If
  
     Case -1  ' Rückwärts blättern angewählt.
         If CurrentRecord > 1 Then
           DoCmd.GoToRecord A_FORM, "Adressen", A_PREVIOUS
           CurrentRecord = CurrentRecord - 1
         Else
           RetValue = Sicherheitsabfrage(5, ER_MESSAGE)
         End If
  
     Case -100 ' Sprung zum Ende angewählt.
         DoCmd.GoToRecord A_FORM, Screen.ActiveForm.FormName, A_LAST
         CurrentRecord = TotalNumOfRec
        
     Case 100 ' Sprung zum Anfang angewählt.
         DoCmd.GoToRecord A_FORM, Screen.ActiveForm.FormName, A_FIRST
         CurrentRecord = 1
        
   End Select

   Forms!Adressen!NumberOfAdresses.Caption = RECORDNUM & CurrentRecord & OF & TotalNumOfRec
  DoCmd.GoToControl Screen.PreviousControl

End Function

IsRuntime()

'===================================================================
'  FUNKTION:   IsRuntime()
'
'  AUFGABE:    Stellt fest, ob mit Runtime gearbeitet wird!
'===================================================================

Function IsRuntime()

On Error GoTo ErrIsRuntime
   IsRuntime = SysCmd(6)

ByeIsRuntime:
   Exit Function

ErrIsRuntime:
   If (Err = 5) Then
     IsRuntime = False
   Else
     Error Err
   End If
   Resume ByeIsRuntime

End Function
 

Formular IstGeladen()

'===================================================================
'  FUNKTION:   IstGeladen()
'
'  AUFGABE:    Stellt fest, ob sich der übergebene Formularname in der Sammlung der
'                         geöffneten Formulare befindet - das Formular also geöffnet/geladen ist.
'=============================================================
Function IstGeladen(MeinFormularname)
  
   Dim I
  
   IstGeladen = False
  
   For I = 0 To Forms.Count - 1
     If Forms(I).FormName = MeinFormularname Then
         IstGeladen = True
         Exit Function       'Schleife nach Auffinden des Formulars verlassen.
     End If
   Next

End Function
 

 Rücksetzen()

'===================================================================
'  FUNKTION: Rücksetzen()
'
'  AUFGABE:    Setzt die Werte in einem Formular auf die vorher dort einge-
'                    gebenen Werte.
'===================================================================
Sub Rücksetzen()

   Dim I As Integer, AnzSteuerelemente As Integer, F As Form
  
   Set F = Screen.ActiveForm
   AnzSteuerelemente = F.Count
  
   If AnzSteuerelemente > 0 Then
     On Error Resume Next
    
     For I = 0 To AnzSteuerelemente - 1
         F(I) = F(I).OldValue
     Next I
  End If

End Sub

Satzkopie()

'=============================================================================
'  FUNKTION:   Satzkopie()
'
'  AUFGABE:    Kopiert die aktuelle Adresse in einen neuen Datensatz.
'======================================================================
Function Satzkopie()
  
   Dim ReturnValue As Integer

   If Forms!Adressen.Dirty Then ReturnValue = Speichern()

   ' Beginn der Transaktion
   BeginTrans
    
     ' Fehlerbehandlungs-Routine definieren
     On Error GoTo Fehler3

     ' Schalte die Sanduhr ein und zeige dem Anwender, daß das System arbeitet.
     DoCmd.Hourglass True
    
     Dim DB1 As Database, Abfrage1 As QueryDef

     Set DB1 = CurrentDb()
     Set Abfrage1 = DB1.CreateQueryDef(CurrentUser() & "5") ' QueryDef erstellen.
     Abfrage1.SQL = "INSERT INTO Adressen ([Firma 1], [Firma 2], Abteilung, Straße, Straße2, Plz, Plz2, Land, Stadt, Gruppe) SELECT DISTINCTROW Adressen.[Firma 1], Adressen.[Firma 2], Adressen.Abteilung, Adressen.Straße, Adressen.Straße2, Adressen.Plz, Adressen.Plz2, Adressen.Land, Adressen.Stadt, Adressen.Gruppe FROM Adressen WHERE (Adressen.Serial = " & Forms!Adressen![Serial] & ") with OWNERACCESS OPTION;"  ' Eigenschaft "SQL" einstellen.
     Abfrage1.Execute
     Abfrage1.Close ' Objekt QueryDef schließen.
     DB1.DeleteQueryDef (CurrentUser() & "5") ' QueryDef löschen.
  
   CommitTrans
  
   DoCmd.Requery
  DoCmd.ShowAllRecords
   DoCmd.GoToRecord A_FORM, "Adressen", A_LAST
  
   ' Anpassen der Systemzählvariablen
   Forms![Adressen]![ErfVon] = UCase(Left$(CurrentUser(), 1)) + LCase(Right$(CurrentUser(), Len(CurrentUser()) - 1))
   Forms![Adressen]![Erfaßt am] = CLng(Date)
   TotalNumOfRec = TotalNumOfRec + 1
   CurrentRecord = TotalNumOfRec
   Forms!Adressen!NumberOfAdresses.Caption = RECORDNUM & CurrentRecord & OF & TotalNumOfRec
  
   DoCmd.Hourglass False
   ReturnValue = Sicherheitsabfrage(19, ER_MESSAGE)
   Exit Function

Fehler3:
  
   StdErrProc
  
   On Error Resume Next
   DB1.DeleteQueryDef (CurrentUser() & "5") ' QueryDef löschen.
   DoCmd.Hourglass False
   Rollback
   Exit Function

End Function

Sicherheitsabfrage()

'==================================================================================
'  FUNKTION:   Sicherheitsabfrage()
'
'  AUFGABE:    Standardfunktion, die sowohl Abfragen darstellt, die Eingaben des
'              Benutzers erwartet, wie auch reine Systemmeldungen auf dem Bildschirm
'              ausgibt.
'===========================================================================
Function Sicherheitsabfrage(ErrorNum, ErrorType)
  
   Dim Formular As Form, UserAntwort As Integer, Mldg As Variant, Typ As Integer
   Dim DB1 As Database, Table1 As Table, Titel As String

   Set DB1 = DBEngine(0)(0)
   Set Table1 = DB1.OpenTable("Systemmeldungen")
   Table1.Index = "PrimaryKey"
   Table1.Seek "=", ErrorNum
  
   ' Wenn die ErrorID nicht gefunden werden konnte ...
   If Table1.NoMatch Then
     Table1.Seek "=", 0
     Mldg = Table1!Systemmeldung
     MsgBox Mldg
     Sicherheitsabfrage = 7
     Exit Function
   End If
  
   Mldg = Table1!Systemmeldung
  
   If ErrorType = ER_SECURE Then
     Typ = MB_JANEIN + MB_SymbolFragezeichen
     Titel = ER_TITEL_SECURE
     Sicherheitsabfrage = MsgBox(Mldg, Typ, Titel)
   Else
     Typ = MB_OK + MB_SymbolInformation
     UserAntwort = MsgBox(Mldg, Typ, AppName)
     Sicherheitsabfrage = 7
     Exit Function
  End If
  
End Function

 

AnzahlDatensätze()

'=============================================================================
'  FUNKTION:   AnzahlDatensätze()
'
'  AUFGABE:    Zählt die Anzahl der jeweils aktuellen Datensätze
'                    Dies gilt auch, wenn ein Filter aktiviert wurde.
'======================================================================
Function AnzahlDatensätze()

   ' Im Falle eines Fehlers ...
   On Error Resume Next

   Dim dyn As Dynaset

   ' Setze diesen Dynaset auf das aktuelle Formular.
   Set dyn = Screen.ActiveForm.Dynaset

   ' Gehe zum letzten Datensatz
   dyn.MoveLast

   ' Gib eine Meldung mit der Anzahl der momentan im Zugriff befindlichen Datensätze aus.
   MsgBox ("Derzeit " & dyn.RecordCount & " Datensätze im Zugriff."), , AppName

   ' Schließe den Dynaset.
   dyn.Close

End Function

 

ButtonAbbruch()

'=============================================================================
'  FUNKTION: ButtonAbbruch()
'
'  AUFGABE:    Schließt das gerade geöffnete Formular.
'======================================================================
Function ButtonAbbruch()

   ' Stellt das aktuelle Formular fest und schließt es.
   DoCmd.Close A_FORM, Screen.ActiveForm.FormName

End Function
 

Runden (max. 5 Nachkomma)

'=============================================================================
'  FUNKTION: Runden#(z#, k%)
'
'  AUFGABE:    runden (max. 5 Nachkomma)
'===============================================================
Public Function Runden#(z#, k%)
' runden (max. 5 Nachkomma)
   Dim l&
   l& = Val("1" & Mid$("00000", 1, k%))
   Runden# = Fix("" & z * l& + Sgn(z) * 0.5) / l&
End Function
 

Alter errechnen

'=============================================================================
'  FUNKTION: Alter(alt)
'  AUFGABE:        Alter errechnen
'======================================================================

Function alter(alt)
   If Not IsDate(alt) Or IsNull(alt) Then
       alter = Null
   Else
         alter = Year(Now()) - Year(alt)
   End If
End Function