471 lines
11 KiB
Plaintext
471 lines
11 KiB
Plaintext
Private Sub BAendern_Click()
|
|
|
|
Dim str1 As String, str2 As String, oldpath As String
|
|
|
|
If Not IsNull(LMandanten) And LMandanten >= 0 Then
|
|
|
|
str1 = ""
|
|
While str1 = ""
|
|
str1 = InputBox("Geben Sie bitte die Mandantenbezeichnung ein:", "Mandanten bearbeiten", DMax("[Bezeichnung]", "Mandanten", "[MANR]=" + Format(LMandanten)))
|
|
Wend
|
|
|
|
str2 = ""
|
|
While str2 = ""
|
|
str2 = InputBox("Geben Sie bitte den Datenpfad ein:", "Mandanten bearbeiten", DMax("[Data]", "Mandanten", "[MANR]=" + Format(LMandanten)))
|
|
Wend
|
|
|
|
Dim db1 As Database
|
|
Dim rs1 As Recordset
|
|
|
|
Set db1 = CurrentDb
|
|
Set rs1 = db1.OpenRecordset("Mandanten")
|
|
|
|
While Not rs1.EOF And rs1!MANR <> CLng(LMandanten)
|
|
rs1.MoveNext
|
|
Wend
|
|
|
|
rs1.Edit
|
|
oldpath = rs1!Data
|
|
rs1!Bezeichnung = str1
|
|
rs1!Data = str2
|
|
rs1.Update
|
|
rs1.Close
|
|
|
|
LMandanten.Requery
|
|
'If MsgBox("Wollen Sie die Daten kopieren", vbYesNo) = vbYes Then
|
|
'
|
|
' If oldpath <> str2 Then
|
|
' FileCopy oldpath, str2
|
|
' End If
|
|
'End If
|
|
End If
|
|
|
|
End Sub
|
|
|
|
Private Sub BLoeschen_Click()
|
|
|
|
If Not IsNull(LMandanten) And LMandanten >= 0 Then
|
|
|
|
If MsgBox("Sind Sie sicher, daß Sie diesen Mandanten löschen wollen ?", vbYesNo) = vbYes Then
|
|
|
|
Dim db1 As Database
|
|
Dim rs1 As Recordset
|
|
|
|
Set db1 = CurrentDb
|
|
Set rs1 = db1.OpenRecordset("Mandanten")
|
|
|
|
While Not rs1.EOF And rs1!MANR <> CLng(LMandanten)
|
|
rs1.MoveNext
|
|
Wend
|
|
|
|
rs1.Delete
|
|
rs1.Close
|
|
|
|
LMandanten.Requery
|
|
End If
|
|
|
|
End If
|
|
|
|
End Sub
|
|
|
|
Private Sub BNeu_Click()
|
|
|
|
Dim str1, str2 As String
|
|
|
|
str1 = ""
|
|
While str1 = ""
|
|
str1 = InputBox("Geben Sie bitte die Mandantenbezeichnung ein:", "Mandanten bearbeiten")
|
|
Wend
|
|
|
|
str2 = ""
|
|
While str2 = ""
|
|
str2 = InputBox("Geben Sie bitte den Datenpfad ein:", "Mandanten bearbeiten", AppPath + "WGDATEN.ACCDB")
|
|
Wend
|
|
|
|
Dim db1 As Database
|
|
Dim rs1 As Recordset
|
|
|
|
Set db1 = CurrentDb
|
|
Set rs1 = db1.OpenRecordset("Mandanten")
|
|
|
|
rs1.AddNew
|
|
rs1!Bezeichnung = str1
|
|
rs1!Data = str2
|
|
rs1.Update
|
|
rs1.Close
|
|
|
|
LMandanten.Requery
|
|
|
|
If InStr(str2, "\") > 0 Then
|
|
If MsgBox("Soll das Daten-Verzeichnis erstellt werden ?", vbYesNo) = vbYes Then
|
|
' Verzeichnis erstellen
|
|
FileSystem.MkDir Mid(GetPathWithoutFilename(str2), 1, Len(GetPathWithoutFilename(str2)) - 1)
|
|
End If
|
|
End If
|
|
|
|
If MsgBox("Wollen Sie eine neue Daten-Datei anlegen ?", vbYesNo) = vbYes Then
|
|
FileCopy GetAppPath + "WGDATEN.ACCDB", str2
|
|
End If
|
|
|
|
End Sub
|
|
|
|
Private Sub BOk_Click()
|
|
|
|
Weiter
|
|
|
|
End Sub
|
|
|
|
|
|
|
|
|
|
Private Sub BRücksichern_Click()
|
|
|
|
|
|
Dim datapath1
|
|
Dim apppath1
|
|
Dim archname
|
|
Dim archname1
|
|
Dim archname2
|
|
Dim cmdstr1
|
|
|
|
Dim sicherungspfad1 As String
|
|
|
|
|
|
|
|
If MsgBox("Sind Sie sicher, daß Sie sämtliche Daten von Diskette rücksichern wollen ? Alle aktuellen WG MASTER Daten auf der Festplatte gehen dabei verloren !!!", vbYesNo) = vbYes Then
|
|
|
|
If IsNull(GetParameter("SICHERUNGSPFAD")) Then
|
|
SetParameter "SICHERUNGSPFAD", "A:\"
|
|
End If
|
|
|
|
sicherungspfad1 = GetParameter("SICHERUNGSPFAD")
|
|
|
|
str1 = InputBox("Bitte geben Sie den Pfad ein, von wo WG MASTER rücksichern soll: ", "Sicherungspfad eingeben", sicherungspfad1)
|
|
If Not IsNull(str1) And str1 <> "" Then
|
|
sicherungspfad1 = str1
|
|
SetParameter "SICHERUNGSPFAD", sicherungspfad1
|
|
End If
|
|
|
|
archname = "wgdata.arj"
|
|
archname2 = sicherungspfad1 + archname
|
|
|
|
datapath1 = GetDataPath
|
|
apppath1 = GetAppPath
|
|
archname1 = GetPathWithoutFilename(GetDataPath) + archname
|
|
|
|
On Error GoTo Error1
|
|
|
|
If Not IsNull(datapath1) And Not IsNull(apppath1) Then
|
|
|
|
|
|
MsgBox ("Bitte Medium in Laufwerk " + sicherungspfad1 + " einlegen (Diskette, ZIP-Medium)")
|
|
|
|
If Fileexist(Format(archname2)) = False Then
|
|
MsgBox "FEHLER: Sicherungsdatei nicht gefunden !", vbCritical
|
|
Exit Sub
|
|
Else
|
|
If Fileexist(Format(archname1)) Then FileSystem.Kill (archname1)
|
|
DoCmd.Hourglass True
|
|
FileCopy archname2, archname1
|
|
If Fileexist(Format(datapath1)) Then FileSystem.Kill (datapath1)
|
|
|
|
FileSystem.ChDrive Left(GetDataPath, 1)
|
|
FileSystem.ChDir GetPathWithoutFilename(GetDataPath)
|
|
cmdstr1 = apppath1 + "arj.exe x -y " + archname1 + " " + GetPathWithoutFilename(GetDataPath) + " " + "WGDATEN.ACCDB"
|
|
'MsgBox (cmdstr1)
|
|
Shell cmdstr1, vbNormalFocus
|
|
FileSystem.ChDir apppath1
|
|
|
|
DoCmd.Hourglass False
|
|
MsgBox ("Daten erfolgreich rückgesichert")
|
|
End If
|
|
|
|
End If
|
|
|
|
Exit Sub
|
|
|
|
End If
|
|
|
|
Error1:
|
|
MsgBox "FEHLER: Datenträger nicht bereit!", vbCritical
|
|
DoCmd.Hourglass False
|
|
Exit Sub
|
|
|
|
|
|
|
|
End Sub
|
|
|
|
Private Sub BSichern_Click()
|
|
|
|
Dim datapath1
|
|
Dim apppath1
|
|
Dim archname
|
|
Dim archname1
|
|
Dim archname2
|
|
Dim cmdstr1
|
|
Dim sicherungspfad1 As String
|
|
Dim str1
|
|
|
|
If IsNull(GetParameter("SICHERUNGSPFAD")) Then
|
|
SetParameter "SICHERUNGSPFAD", "A:\"
|
|
End If
|
|
|
|
sicherungspfad1 = GetParameter("SICHERUNGSPFAD")
|
|
|
|
str1 = InputBox("Bitte geben Sie den Pfad ein, wohin WG MASTER sichern soll: ", "Sicherungspfad eingeben", sicherungspfad1)
|
|
If Not IsNull(str1) And str1 <> "" Then
|
|
sicherungspfad1 = str1
|
|
SetParameter "SICHERUNGSPFAD", sicherungspfad1
|
|
End If
|
|
|
|
|
|
archname = "wgdata.arj"
|
|
archname2 = sicherungspfad1 + archname
|
|
|
|
datapath1 = GetDataPath
|
|
apppath1 = GetAppPath
|
|
archname1 = GetPathWithoutFilename(GetDataPath) + archname
|
|
|
|
'MsgBox (datapath1)
|
|
'MsgBox (apppath1)
|
|
'MsgBox (archname1)
|
|
'MsgBox (archname2)
|
|
|
|
On Error GoTo Error1
|
|
|
|
If Not IsNull(datapath1) And Not IsNull(apppath1) Then
|
|
DoCmd.Hourglass True
|
|
|
|
|
|
If Fileexist(Format(archname1)) = True Then FileSystem.Kill (archname1)
|
|
|
|
FileSystem.ChDrive Left(GetDataPath, 1)
|
|
FileSystem.ChDir GetPathWithoutFilename(GetDataPath)
|
|
cmdstr1 = apppath1 + "arj.exe a " + archname1 + " " + "WGDATEN.ACCDB"
|
|
'MsgBox (cmdstr1)
|
|
Shell cmdstr1, vbNormalFocus
|
|
FileSystem.ChDir apppath1
|
|
|
|
MsgBox ("Bitte Medium in Laufwerk " + sicherungspfad1 + " einlegen (Diskette, ZIP-Medium)")
|
|
|
|
If Fileexist(Format(archname2)) Then FileSystem.Kill (archname2)
|
|
|
|
FileCopy archname1, archname2
|
|
FileSystem.Kill archname1
|
|
If Fileexist(Format(archname1)) Then FileSystem.Kill (archname1)
|
|
|
|
DoCmd.Hourglass False
|
|
MsgBox ("Daten erfolgreich gesichert")
|
|
End If
|
|
|
|
Exit Sub
|
|
|
|
Error1:
|
|
MsgBox "FEHLER: Datenträger nicht bereit!", vbCritical
|
|
DoCmd.Hourglass False
|
|
Exit Sub
|
|
|
|
|
|
|
|
|
|
End Sub
|
|
|
|
Private Sub Form_Close()
|
|
|
|
'docmd.quit
|
|
|
|
End Sub
|
|
|
|
Private Sub Form_Open(Cancel As Integer)
|
|
|
|
LMandanten.SetFocus
|
|
If Not IsNull(LMandanten.ItemData(0)) Then LMandanten = LMandanten.ItemData(0)
|
|
|
|
End Sub
|
|
|
|
Private Sub LMandanten_DblClick(Cancel As Integer)
|
|
|
|
Weiter
|
|
|
|
End Sub
|
|
|
|
Sub Weiter()
|
|
|
|
If Not IsNull(LMandanten) And LMandanten >= 0 Then
|
|
|
|
Dim manr1 As Long
|
|
Dim Data As String
|
|
Dim datapath As String
|
|
|
|
DoCmd.Hourglass True
|
|
|
|
manr1 = LMandanten
|
|
|
|
Data = DMax("[Data]", "Mandanten", "MANR=" + Format(manr1))
|
|
|
|
'MsgBox (data)
|
|
|
|
If FileSystem.FileLen(Data) > 0 Then
|
|
|
|
datapath = GetPathWithoutFilename(Data)
|
|
|
|
'MsgBox ("1")
|
|
|
|
SetLinkTablePath "", Data
|
|
|
|
|
|
|
|
|
|
'Check runtime or full version
|
|
If UCase(Right(CurrentDb.Name, 1)) = "B" Then 'MDB or ACCDB
|
|
|
|
|
|
If manr1 <> GetLastMANR() Then
|
|
SetLastMANR (manr1)
|
|
SetReportControlProperty1 "", "BLogo", acImage, "Picture", datapath + "LOGO.BMP"
|
|
End If
|
|
|
|
|
|
'Vollupdate prüfen
|
|
'MsgBox ("2")
|
|
DoCmd.OpenForm "MHauptmenü", acDesign
|
|
|
|
If Forms("MHauptmenü").XVersion2.Caption = "Vollupdate" Then
|
|
'1. Logo aktualisieren
|
|
|
|
'MsgBox ("3")
|
|
SetReportControlProperty1 "", "BLogo", acImage, "Picture", datapath + "LOGO.BMP"
|
|
|
|
|
|
'2. SQL Statements ausführen
|
|
Dim db1 As Database
|
|
Dim cnt1 As Container
|
|
Dim doc1 As Document
|
|
|
|
' Current Database for SQL Statements
|
|
Dim db2 As Database
|
|
Dim rs1 As Recordset
|
|
|
|
|
|
Set db2 = Application.DBEngine.Workspaces(0).OpenDatabase(GetDataPath())
|
|
|
|
Set db1 = CurrentDb
|
|
For Each cnt1 In db1.Containers
|
|
|
|
If cnt1.Name = "Tables" Then
|
|
For Each doc1 In cnt1.Documents
|
|
If doc1.Name = "Update_SQLStatements" Then
|
|
Set rs1 = db1.OpenRecordset("Update_SQLStatements")
|
|
While Not rs1.EOF
|
|
'If MsgBox(rs1!Beschreibung + " ?", vbYesNo) = vbYes Then
|
|
On Error Resume Next
|
|
db2.Execute (rs1!SQLStatement)
|
|
'End If
|
|
rs1.MoveNext
|
|
Wend
|
|
rs1.Close
|
|
db1.Execute ("DROP Table Update_SQLStatements")
|
|
End If
|
|
Next doc1
|
|
End If
|
|
|
|
Next cnt1
|
|
|
|
'3. Übernahmeformular - Kommunikationsparameter einstellen
|
|
'DoCmd.OpenForm "FÜbernahme", acDesign
|
|
|
|
'MsgBox (GetParameter("WAAGEPORTSETTINGS"))
|
|
'MsgBox (CLng(GetParameter("WAAGEPORT")))
|
|
'MsgBox (CLng(GetParameter("STEUERUNGPORT")))
|
|
|
|
'Forms!FÜbernahme!XComm.Settings = GetParameter("WAAGEPORTSETTINGS")
|
|
'Forms!FÜbernahme!XComm.CommPort = CLng(GetParameter("WAAGEPORT"))
|
|
'Forms!FÜbernahme!XCommSteuerung.CommPort = CLng(GetParameter("STEUERUNGPORT"))
|
|
|
|
'DoCmd.Save
|
|
'DoCmd.Close
|
|
|
|
'4. Vollupdate Label entfernen
|
|
Forms("MHauptmenü").XVersion2.Caption = ""
|
|
DoCmd.Save
|
|
|
|
End If
|
|
|
|
DoCmd.Close
|
|
|
|
End If
|
|
|
|
DoCmd.Hourglass False
|
|
DoCmd.OpenForm "MHauptmenü"
|
|
|
|
End If
|
|
|
|
|
|
|
|
End If
|
|
|
|
End Sub
|
|
|
|
Function SetReportControlProperty1(reportname As String, ControlName As String, Controltype As Integer, PropertyName As String, PropertyValue As Variant)
|
|
' Sets the given property of the given control in the given form to the given value
|
|
' If Formname="" then all forms
|
|
' If Controlname="" then all controls
|
|
|
|
Dim sec1 As Section
|
|
Dim ctl1 As Control
|
|
Dim i As Variant
|
|
|
|
If reportname = "" Or IsNull(reportname) Then
|
|
'All Reports
|
|
Dim db1 As Database
|
|
Dim cnt1 As Container
|
|
Dim doc1 As Document
|
|
|
|
Set db1 = CurrentDb
|
|
For Each cnt1 In db1.Containers
|
|
If cnt1.Name = "Reports" Then
|
|
For Each doc1 In cnt1.Documents
|
|
DoCmd.OpenReport doc1.Name, acViewDesign
|
|
|
|
On Error Resume Next
|
|
'look into all sections
|
|
For i = 0 To 8
|
|
'If Reports(doc1.Name).Section(i).Visible = True Then
|
|
Reports(doc1.Name).Controls(ControlName).Properties(PropertyName) = PropertyValue
|
|
'Set sec1 = Reports(doc1.Name).Section(i)
|
|
'For Each ctl1 In sec1.Controls
|
|
'If ctl1.Name = ControlName Or ControlName = "" Or IsNull(ControlName) Then
|
|
'If Controltype = ctl1.Controltype Or Controltype = -1 Then
|
|
'On Error Resume Next
|
|
'ctl1.Properties(PropertyName) = PropertyValue
|
|
'End If
|
|
'End If
|
|
'Next ctl1
|
|
'End If
|
|
Next i
|
|
DoCmd.Save
|
|
DoCmd.Close
|
|
Next doc1
|
|
End If
|
|
Next cnt1
|
|
|
|
Else
|
|
DoCmd.OpenReport reportname, acViewDesign
|
|
For i = 0 To 8
|
|
Set sec1 = Reports(reportname).Section(i)
|
|
For Each ctl1 In sec1.Controls
|
|
If ctl1.Name = ControlName Or ControlName = "" Or IsNull(ControlName) Then
|
|
On Error Resume Next
|
|
ctl1.Properties(PropertyName) = PropertyValue
|
|
End If
|
|
Next ctl1
|
|
Next i
|
|
DoCmd.Save
|
|
DoCmd.Close
|
|
End If
|
|
|
|
|
|
|
|
|
|
|
|
End Function |