Exported VBA
This commit is contained in:
471
wgmaster/vba/Form_MMandantenauswahl.frm
Normal file
471
wgmaster/vba/Form_MMandantenauswahl.frm
Normal file
@ -0,0 +1,471 @@
|
||||
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
|
||||
Reference in New Issue
Block a user