|
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ActiveSheet.EnableSelection = xlUnlockedCells
End Sub
Sub Rekla2021_Starten()
If Trim(ActiveWorkbook.Name) = "REKLA 2021.xls" Then
Dim db_Open As Boolean
db_Open = False
Felder_leeren
Setzen_DDN_AbweichFiliale
AuswahlFiliale_unterdruecken
AuswahlFiliale_fuellen db_Open
DialogSheets("ReklaDialog").Show
ActiveWorkbook.Save
ElseIf Trim(ActiveWorkbook.Name) = "REKLA 2021.xls" Then
MsgBox "Falsche Arbeitsmappe für diesen Button ausgewählt.", vbOKOnly
End If
End Sub
Sub Blattschutz_aufheben()
ActiveSheet.Unprotect deinpasswort
End Sub
Sub txf_vorgangsNr_BeiÄnderung()
PruefeObeineZahl
End Sub
Sub txf_reklamBetrag_BeiÄnderung()
PruefeObeineZahl
End Sub
Sub ddn_auswahlFiliale_BeiÄnderung()
End Sub
Sub ddn_auswahlFiliale_Klicken()
End Sub
Sub txf_rechnungsNr_BeiÄnderung()
PruefeObeineZahl
End Sub
Public Function bekommeBlattvomCodeName(CodeName As String, _
Optional Sheet As Object, _
Optional InWorkbook As Workbook) As Boolean
If InWorkbook Is Nothing Then
Set InWorkbook = ThisWorkbook
End If
For Each Sheet In InWorkbook.Sheets
If StrComp(Sheet.Name, CodeName, vbTextCompare) = 0 Then
bekommeBlattvomCodeName = True
Exit For
End If
Next
End Function
Sub btn_DatenEinlesen_Klicken()
Dim db_Stat As Boolean
Dim diag As Object
Dim mydrop As Object
Dim mydrop1 As Object
Dim mylabel As Object
Dim mytxfvorgang As Object
Dim mytxfrechnung As Object
Dim myarray
Dim aktAbweichFiliale As Integer
Dim aktAuswahlFiliale As Integer
Dim NameAuswahlFiliale As String
Dim txf_vorgangsNr As Long
Dim txf_rechnungsNr As Variant
Dim abweichungFiliale As Integer
'Dim statussetzen As String 'Test
Set diag = DialogSheets("ReklaDialog")
Set mydrop = diag.DropDowns("ddn_abweichFiliale")
Set mydrop1 = diag.DropDowns("ddn_auswahlFiliale")
Set mytxfvorgang = diag.EditBoxes("txf_vorgangsNr")
Set mytxfrechnung = diag.EditBoxes("txf_rechnungsNr")
'Set statussetzen = diag.EditBoxes("txf_rechnungsNr") 'Test
abweichungFiliale = 0
aktAbweichFiliale = mydrop.ListIndex
aktAuswahlFiliale = mydrop1.ListIndex
If (mytxfvorgang.Text <> "") Then
'txf_vorgangsNr = diag.EditBox("txf_vorgangsNr").Value
txf_vorgangsNr = CVar(mytxfvorgang.Text)
Else
MsgBox "Geben Sie bitte eine gültige Vorgangsnummer an.", vbInformation, "Fehler:"
Exit Sub
End If
If (mytxfrechnung.Text <> "") Then
txf_rechnungsNr = CDec(mytxfrechnung.Text)
Else
MsgBox "Geben Sie bitte eine Rechnungsnummer an.", vbInformation, "Fehler:"
Exit Sub
End If
' Wenn das DropdownFeld "Auswahl Filiale" auf Nein gesetzt wurde
If (aktAbweichFiliale = 1) Then
abweichungFiliale = 1
FindeTabellenblatt db_Stat, NameAuswahlFiliale, abweichungFiliale, txf_vorgangsNr, txf_rechnungsNr
Else
NameAuswahlFiliale = mydrop1.List(aktAuswahlFiliale)
abweichungFiliale = 2
FindeTabellenblatt db_Stat, NameAuswahlFiliale, abweichungFiliale, txf_vorgangsNr, txf_rechnungsNr
End If
End Sub
Sub btn_StatusSetzen_Klicken()
Dim db_Status As Boolean
Const adOpenForwardOnly As Long = 0
'Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim db As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim sConnect As String
Dim anzahlDS As Integer
Dim sSQL As String
Dim AuftragNr As Integer
Dim RechnungNr As Integer
'Dim Rechnungsposition As Integer
'Dim sSQLr As String
'Dim filialeKurz
Dim diag As Object
Dim i As Integer
Set diag = DialogSheets("ReklaDialog")
If db_Status = False Then
'sSQL = "SELECT KURZNAME FROM sani97.dbo.Filiale Order By FilialeNr "
sSQL = "SELECT * FROM sani.dbo.AuftragStatusZuordnung, Rechnungsposition" '* from AuftragStatusZuordnung, Rechnungsposition
'sSQL = "SELECT * FROM sani97.dbo.AuftragStatusZuordnung JOIN AuftragNr where RechnungNr" 'sposition"
'AuftragNr, Vorgangnr anstatt *
'sSQLr = "SELECT RechnungsNr FROM sani97.dbo.Rechnungsposition"
'sSQL = "SELECT AuftragNr FROM sani97.dbo.AuftragStatusZuordnung INNER JOIN AuftragsStatusZuordnung ON Rechnungsposition.RechnungNr = AuftragsStatusZuordnung.AuftragNr" WHERE (((Rechnungsposition.RechnungNr) Is Not Null And (Rechnungsposition.RechnungNr) <> 0) And ((Rechnungsposition.Vorgangnr) Is Not Null And (Rechnungsposition.Vorgangnr) <> 0))
sConnect = "DSN=sani97;" & _
"UID=sani_user;" & _
"PWD=sani97;" & _
"IFSN=sani97sql;" & _
"DB=sani97;" & _
"applicationname=REKLA-EXCEL"
'On Error GoTo Login_Error
db.Open sConnect
MsgBox sConnect
db_Status = True
'Erzeugen des Recordsets mit Schreibrechten
MsgBox sSQL
rs.Open sSQL, sConnect, adOpenUnspecified, adLockOptimistic, adCmdText
'MsgBox sSQLr
' rs.Open sSQLr, sConnect, adOpenUnspecified, adLockOptimistic, adCmdText
'adOpenKeyset
With rs
' .MoveFirst
' .Find Criteria:=KriteriumAngeben, SearchDirection:=adSearchForward
If .Fields("RechnungNr") = True Then
MsgBox "Ist vorhanden"
Else
If .Fields("AuftragNr") = True Then
MsgBox "Ist vorhanden"
End If
End If
' .Find Criteria:="AuftragNr='Zahl'", SearchDirection:=adSearchForward
' If .EOF = True Then
' MsgBox "Kein passender Datensatz gefunden"
' Else
' .Fields(Spaltenname).Value = "Gewünschten Wert eintragen"
' .Fields("AuftragNr").Value = "Gewünschten Wert eintragen"
' End If
' .Close 'schließt das Recordset
End With
' 'Überprüfung ob Daten zurückgeliefert wurden
' If Not rs.EOF And rs.RecordCount > 0 Then
'
' filialeKurz = rs.GetRows
' anzahlDS = rs.RecordCount
'
' 'MsgBox "Anzahl an Datensätzen = " & anzahlDS
'
' With diag.DropDowns("ddn_auswahlFiliale")
' .ListFillRange = anzahlDS - 1
' .DropDownLines = 20
' For i = 0 To anzahlDS - 1
' .AddItem CStr(filialeKurz(0, i))
' 'ThisWorkbook.DialogSheets("ReklaDialog").DropDowns(2).AddItem (filialeKurz(0, 1))
' Next
' End With
' Else
' MsgBox "Keine Daten zu der Vorgangsnummer in SaniVision gefunden.", vbCritical
' Exit Sub
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
db_Status = False
MsgBox "Es existiert bereits eine Datenbankverbindung zu SaniViison.", vbInformation
Exit Sub
Login_Error:
MsgBox "Error #: " & Err.Number & " : Es konnte keine Verbindung zu SaniVision hergestellt werden. Bitte wenden Sie sich an Ihren Administrator.", vbCritical
End If
End Sub
Sub btn_ReklaErstellen_Klicken()
Dim b As Integer
For b = 1 To Sheets.Count
If (Sheets(b).Name <> "ReklaDialog" And Sheets(b).Name <> "WICHTIGE HINWEISE") Then
'MsgBox (Sheets(b).Name)
Call ErmittleZuDruckendeReklas(Sheets(b).Name)
Else
End If
Next b
'Call ErmittleZuDruckendeReklas("10")
MsgBox "Ihre Rechnungsreklamation wurden erfolgreich an den Drucker gesendet.", vbInformation
End Sub
Sub ErmittleZuDruckendeReklas(wTBName As String)
Dim objwCell 'da stand nix
Dim objwrange As Range
Dim objwsheet As Worksheet
Dim objwworkbook As Workbook
Dim C As Integer
Dim wletztegefZeile As Integer
Dim woFilialeKurz As String
Dim woReklaNr As String
Dim woReklaBetrag As String
Dim woVorgangsNr As Long
Dim woKostentraeger As String
Dim woKunde As String
Dim woRechnungsNr As Variant
Dim woErstelltDatum As Date
Dim woRueckgabeDatum As Date
'Neue Zeilen
'Const MissingValue As Long = -10000000
'If IsNumeric(.Cells(C, 3).Value) Then
'woVorgangsNr = CLng(.Cells(C, 3).Value)
'Else
'woVorgangsNr = MissingValue
'End If
'Ende neue Zeilen
Set objwworkbook = Application.Workbooks("REKLA 2021.xls")
Set objwsheet = objwworkbook.Sheets(wTBName)
woFilialeKurz = ""
woReklaNr = 0
woReklaBetrag = 0 '"" '0
woVorgangsNr = 0 '"" '0
woKostentraeger = ""
woKunde = ""
woRechnungsNr = 0
woErstelltDatum = Empty
woRueckgabeDatum = Empty
'Hier wir die letzte beschriebene Zeile der Spalte A ermittelt
With Workbooks("REKLA 2021.xls").Worksheets(wTBName)
wletztegefZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
'MsgBox "letzte, befüllte Zeille = " & wletztegefZeile
For C = 4 To wletztegefZeile
With Workbooks("REKLA 2021.xls").Worksheets(wTBName)
If Trim(.Cells(C, 1)) <> "" Then
If (Trim(.Cells(C, 4)) <> "x" And Trim(.Cells(C, 4)) <> "X") Then
'MsgBox "noch nicht gedruckt!! Tabellenblatt = " & wTBName & " Zeile = " & c
woReklaNr = .Cells(3, 1).Value & .Cells(C, 1).Value
woReklaBetrag = FormatNumber(.Cells(C, 2).Value) 'Format(.Cells(C, 2).Value = Empty)
woVorgangsNr = .Cells(C, 3).Value
'Then woVorgangsNr = CLng(.Cells(C, 3).Value)
'Else woVorgangsNr = MissingValue End If
woKostentraeger = .Cells(C, 8).Value
woKunde = .Cells(C, 9).Value
woRechnungsNr = .Cells(C, 10).Value
woErstelltDatum = .Cells(C, 11).Value
woRueckgabeDatum = .Cells(C, 12).Value
woFilialeKurz = Filialbezeichnung_ermitteln(wTBName)
Call Word_Dokument_von_Excel_aus_steuern(woFilialeKurz, woReklaNr, woReklaBetrag, woVorgangsNr, woKostentraeger, woKunde, woRechnungsNr, woErstelltDatum, woRueckgabeDatum)
.Cells(C, 4).Value = "X"
ActiveWorkbook.Save
Else
'MsgBox "bereits gedruckt" & .Cells(c, 4) & " Zeile = " & c
End If
Else
End If
End With
Next C
End Sub
Sub Word_Dokument_von_Excel_aus_steuern(wFilialeKurz As String, _
wReklaNr As String, _
wReklaBetrag As String, _
wVorgangsNr As Long, _
wKostentraeger As String, _
wKunde As String, _
wRechnungsNr As Variant, _
wErstelltDatum As Date, _
wRueckgabeDatum As Date)
Dim myWord, objWW, ws As Object
Dim strWordDokument As String
Dim sDruckerAktuell As String
'strWordDokument = "C:\temp\BL-1100581-Rechnungsrekla.dotx"
strWordDokument = "O:\Bereiche\Verwaltung\Debitoren\Rekla\Formular\BL-1100581-Rechnungsrekla.dotx"
'Fehlerroutine für die Objectabfrage aktivieren
On Error Resume Next
'Abfragen einer besthenden WORD-Instanz um wiederholtes starten zu verhindern
Set myWord = GetObject("Word.Application")
If Err.Number <> 0 Then
'Fehlervariable leeren wenn Instanz noch nicht besteht
Err.Clear
'Zuweisung der Instanz
Set myWord = CreateObject("Word.Application")
'Instanz öffnen
'Um das ganze etwas im Hintergrund laufen zu lassen
'kann man den Status "wdWindowStateMinimize" verwenden
'myWord.Visible = False: objWW.WindowState = wdWindowStateMinimize
myWord.Visible = False
Else
'Instanz besteht bereits
myWord.Activate
'Instanz in der Vordergrund bringen oder
'mit "wdWindowStateMinimize" im Hintergrund ausführen
'mit "wdWindowStateMaximize" nicht im Hintergrund ausführen
myWord.Visible = False
End If
'Hier muss der Dateiname stehen der verwendet werden soll
'Es sollte aber eine Dokumentvorlage verwendet werden
'um keine Änderungen an den Textmarken beim einfügen zu verursachen
'myWord.Documents.Open (strWordDokument)
myWord.Documents.Add (strWordDokument)
'Die Textmarken "a1, a2, a3" müssen im Dokument bereits bestehen
'Dann werden nach dem öffnen des Dokuments die Werte von Tabelle1
'A1, B1 und C1 in die jeweiligen Textmarken geschrieben
'If myWord.ActiveDocument.Bookmarks.Exists("wFiliale") = True Then
' 'myWord.ActiveDocument.Bookmarks("wFiliale").Select
' 'myWord.ActiveDocument.Bookmarks("wFiliale").Range.Text = Worksheets("10").Range("B5")
' myWord.ActiveDocument.Bookmarks("wFiliale").Range.Text = wFiliale
'End If
'With myWord.ActiveDocument.Bookmarks
' If .Exists("wReklaNr") = True Then
' Set ReklaRange = ActiveDocument.Bookmarks("wReklaNr").Range
' ReklaRange.Text = wReklaNr
' 'myWord.ActiveDocument.Bookmarks("wReklaNr").Range.Text = wReklaNr
' End If
'
' ' Textmarke recykeln
' .Add Range:=wReklaNr, Name:="wReklaNr"
'End With
With myWord.ActiveDocument
If .Bookmarks.Exists("wFiliale") = True Then
.Bookmarks("wFiliale").Range.Text = wFilialeKurz
End If
If .Bookmarks.Exists("wReklaNr") = True Then
.Bookmarks("wReklaNr").Range.Text = wReklaNr
End If
If .Bookmarks.Exists("wKostentraeger") = True Then
.Bookmarks("wKostentraeger").Range.Text = wKostentraeger
End If
If .Bookmarks.Exists("wKunde") = True Then
.Bookmarks("wKunde").Range.Text = wKunde
End If
If .Bookmarks.Exists("wReklaBetrag") = True Then
.Bookmarks("wReklaBetrag").Range.Text = wReklaBetrag
End If
If .Bookmarks.Exists("wRechnungsNr") = True Then
.Bookmarks("wRechnungsNr").Range.Text = wRechnungsNr
End If
If .Bookmarks.Exists("wVorgangsNr") = True Then
.Bookmarks("wVorgangsNr").Range.Text = wVorgangsNr
End If
If .Bookmarks.Exists("wErstelltDatum") = True Then
.Bookmarks("wErstelltDatum").Range.Text = wErstelltDatum
End If
If .Bookmarks.Exists("wRueckgabeDatum") = True Then
.Bookmarks("wRueckgabeDatum").Range.Text = wRueckgabeDatum
End If
'Felder auf Formular-Kopie
If .Bookmarks.Exists("kwFiliale") = True Then
.Bookmarks("kwFiliale").Range.Text = wFilialeKurz
End If
If .Bookmarks.Exists("kwReklaNr") = True Then
.Bookmarks("kwReklaNr").Range.Text = wReklaNr
End If
If .Bookmarks.Exists("kwKostentraeger") = True Then
.Bookmarks("kwKostentraeger").Range.Text = wKostentraeger
End If
If .Bookmarks.Exists("kwKunde") = True Then
.Bookmarks("kwKunde").Range.Text = wKunde
End If
If .Bookmarks.Exists("kwReklaBetrag") = True Then
.Bookmarks("kwReklaBetrag").Range.Text = wReklaBetrag
End If
If .Bookmarks.Exists("kwRechnungsNr") = True Then
.Bookmarks("kwRechnungsNr").Range.Text = wRechnungsNr
End If
If .Bookmarks.Exists("kwVorgangsNr") = True Then
.Bookmarks("kwVorgangsNr").Range.Text = wVorgangsNr
End If
If .Bookmarks.Exists("kwErstelltDatum") = True Then
.Bookmarks("kwErstelltDatum").Range.Text = wErstelltDatum
End If
If .Bookmarks.Exists("kwRueckgabeDatum") = True Then
.Bookmarks("kwRueckgabeDatum").Range.Text = wRueckgabeDatum
End If
End With
'For Each ws In Worksheets
' MsgBox ws.Name
'Next ws
'Aktuellen Standarddrucker merken
sDruckerAktuell = Application.ActivePrinter
MsgBox "Aktiver Drucker = " & sDruckerAktuell
myWord.ActivePrinter = "\\server-28\Canon Farbe"
'myWord.ActiveDocument.msoBlackWhiteBlack = False
'MsgBox "Farbeinstellungen des Druckers: " & myWord.ActivePrinter.ColorMode
'myWord.ActivePrinter.ColorMode = Color
'Das aktive WordDokument drucken
myWord.ActiveDocument.PrintOut
'Den vorherigen Standarddrucker wieder setzen
myWord.ActivePrinter = "\\server-28\Canon"
'Dokument schliessen ohne speichern
myWord.ActiveDocument.Close savechanges:=False
'myWord.ActiveDocument.Close savechanges:=True
'Speichern mit fixem Namen
'myWord.ActiveDocument.SaveAs Filename:="DokumentName", FileFormat:=wdFormatDocument
'Speichern mit Variable
'myWord.ActiveDocument.SaveAs Filename:=Variable, FileFormat:=wdFormatDocument
'WORD-Instanz schliessen
myWord.Application.Quit (True)
'Variable leeren
Set myWord = Nothing
End Sub
'-------------------------------------------------
'Sub Test2()
'
''Im Excel VBA-Editor für die Datei mit diesem Makro unter Extras-Verweise _
'den Verweis auf die Microsoft Word x.y Object Library aktivieren!!
'Dim WinWord, WinDoc As Word.Document, docSerienbrief As Word.Document
'Dim sFile As String
'Dim strCon As String
'Dim strWOrdvorlage As String
'Dim strDatenQuelle As String
'
'strWOrdvorlage = "C:\Users\Noffke\Desktop\BL-1100581-Rechnungsrekla.docx"
'strDatenQuelle = "C:\Users\Noffke\Desktop\REKLA 2015.xls"
'
'sFile = strWOrdvorlage
'Set WinWord = CreateObject("Word.Application")
'
'With WinWord
' .Visible = True
' 'Vorlagedatei öffnen
' Set WinDoc = .Documents.Open(sFile)
' With WinDoc
' With .MailMerge
' 'Datenquelle öffnen
' .OpenDataSource Name:=strDatenQuelle, _
' Connection:="Provider=Microsoft.Jet.OLEDB.4.0;" _
' & "Data Source=" & strDatenQuelle & ";" _
' & "Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";" _
' & "Jet OLEDB:Engine ", _
' SQLStatement:="SELECT * FROM `Tabelle1$`"
' 'Serienbrief mit allen Daten in neuem Dokument erstellen
' .Destination = wdSendToNewDocument
' .SuppressBlankLines = True
' With .DataSource
' .FirstRecord = wdDefaultFirstRecord
' .LastRecord = wdDefaultLastRecord
' End With
' .Execute Pause:=False
'
' Set docSerienbrief = WinWord.ActiveDocument
' 'Datenquelle wieder schliessen
' .DataSource.Close
' End With
'
' 'Vorlagedatei wieder schliessen
' .Close savechanges:=False
' End With
'
' 'Serienbrief - Drucken - Seitenvorschau
' docSerienbrief.Application.WindowState = wdWindowStateMinimize
' If MsgBox("Serienbrief Drucken ?", vbYesNo + vbQuestion, _
' "Serienbrief-Erstellung - Drucken - Seitenvorschau") = vbYes Then
' docSerienbrief.Application.WindowState = wdWindowStateMaximize
' docSerienbrief.PrintPreview
' ' docSerienbrief.PrintOut
' End If
'
' 'Serienbrief - Speichern
' docSerienbrief.Application.WindowState = wdWindowStateMinimize
' If MsgBox("Serienbrief Speichern ?", vbYesNo + vbQuestion, _
' "Serienbrief-Erstellung-Speicehrn") = vbYes Then
' docSerienbrief.Application.WindowState = wdWindowStateMaximize
' docSerienbrief.Application.Dialogs(wdDialogFileSaveAs).Show
' End If
'
' docSerienbrief.Application.WindowState = wdWindowStateMaximize
'End With
'
'Set docSerienbrief = Nothing
'Set WinWord = Nothing
'Set WinDoc = Nothing
'
'End Sub
'-----------------------------------------------------------------------
Sub btn_Abbrechen_Klicken()
End Sub
Sub Felder_leeren()
ThisWorkbook.DialogSheets("ReklaDialog").EditBoxes("txf_vorgangsNr").Text = ""
ThisWorkbook.DialogSheets("ReklaDialog").EditBoxes("txf_reklamBetrag").Text = ""
ThisWorkbook.DialogSheets("ReklaDialog").EditBoxes("txf_rechnungsNr").Text = ""
ThisWorkbook.DialogSheets("ReklaDialog").DropDowns("ddn_auswahlFiliale").List = ""
End Sub
Sub ddn_abweichFiliale_BeiÄnderung()
Dim diag As Object
Dim mydrop As Object
Dim mydrop1 As Object
Dim mylabel As Object
Dim myarray
Dim aktAbweichFiliale As Integer
Set diag = DialogSheets("ReklaDialog")
Set mydrop = diag.DropDowns("ddn_abweichFiliale")
Set mydrop1 = diag.DropDowns("ddn_auswahlFiliale")
Set mylabel = diag.Labels("Bezeichnung 7")
aktAbweichFiliale = mydrop.ListIndex
' Wenn das DropdownFeld "Auswahl Filiale" auf Nein gesetzt wurde
If (aktAbweichFiliale = 1) Then
mydrop1.Visible = False
mylabel.Visible = False
Else
mydrop1.Visible = True
mylabel.Visible = True
End If
End Sub
Sub PruefeObeineZahl()
Dim sZuPruefendesEingabefeld As EditBox
Set sZuPruefendesEingabefeld = ActiveDialog.EditBoxes(Application.Caller)
If Not IsNumeric(sZuPruefendesEingabefeld.Text) And sZuPruefendesEingabefeld.Text <> "" Then
Beep
MsgBox "Buchstaben oder Sonderzeichen sind nicht erlaubt !", vbInformation, "Fehler:"
sZuPruefendesEingabefeld.Text = Left(sZuPruefendesEingabefeld.Text, _
Len(sZuPruefendesEingabefeld.Text) - 1)
SendKeys "{end}"
End If
End Sub
Sub Setzen_DDN_AbweichFiliale()
Dim diag As Object
'Dim mylist As Object
Dim mydrop As Object
Dim myarray
Dim x As Integer
Set diag = DialogSheets("ReklaDialog")
'Set mylist = diag.ListBoxes("List Box 4")
Set mydrop = diag.DropDowns("ddn_abweichFiliale")
'mylist.RemoveAllItems
mydrop.RemoveAllItems
myarray = Array("Nein", "Ja")
For x = 0 To 1
'mylist.AddItem myarray(x)
mydrop.AddItem myarray(x)
Next x
mydrop.ListIndex = 1
End Sub
Sub AuswahlFiliale_unterdruecken()
Dim diag As Object
Dim mydrop As Object
Dim mylabel As Object
Set diag = DialogSheets("ReklaDialog")
Set mydrop = diag.DropDowns("ddn_auswahlFiliale")
Set mylabel = diag.Labels("Bezeichnung 7")
mydrop.Visible = False
mylabel.Visible = False
End Sub
Function Filialbezeichnung_ermitteln(dbTBName As String)
Const adOpenForwardOnly As Long = 0
Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim db1 As New ADODB.Connection
Dim rs4 As New ADODB.Recordset
Dim db_Status As Boolean
Dim sConnect4 As String
Dim sSQL4 As String
Dim rsFilialeKurz
Dim dbFilialeKurz As String
Dim dbFiliale As Integer
db_Status = False
If db_Status = False Then
dbFiliale = CInt(dbTBName)
sSQL4 = "SELECT KURZNAME FROM sani97.dbo.Filiale WHERE FilialeNr = " & dbFiliale
sConnect4 = "DSN=sani97;" & _
"UID=sani_user;" & _
"PWD=sani97;" & _
"IFSN=sani97sql;" & _
"DB=sani97;" & _
"applicationname=REKLA-EXCEL"
'On Error GoTo Login_Error
db1.Open sConnect4
db_Status = True
'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs4.Open sSQL4, sConnect4, adOpenKeyset, adLockReadOnly, adCmdText
'Überprüfung ob Daten zurückgeliefert wurden
If Not rs4.EOF And rs4.RecordCount > 0 Then
rsFilialeKurz = rs4.GetRows
dbFilialeKurz = rsFilialeKurz(0, 0)
Filialbezeichnung_ermitteln = dbFilialeKurz
Exit Function
Else
MsgBox "Die Filale wurde nicht in SaniVision gefunden.", vbCritical
Filialbezeichnung_ermitteln ""
Exit Function
End If
rs4.Close
db1.Close
Set rs4 = Nothing
Set db1 = Nothing
db_Status = False
Else
MsgBox "Es existiert bereits eine Datenbankverbindung zu SaniViison.", vbInformation
Exit Function
End If
Exit Function
Login_Error:
MsgBox "Error #: " & Err.Number & " : Es konnte keine Verbindung zu SaniVision hergestellt werden. Bitte wenden Sie sich an Ihren Administrator.", vbCritical
End Function
Sub AuswahlFiliale_fuellen(db_Status As Boolean)
Const adOpenForwardOnly As Long = 0
Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim db As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim sConnect As String
Dim anzahlDS As Integer
Dim sSQL As String
Dim filialeKurz
Dim diag As Object
Dim i As Integer
Set diag = DialogSheets("ReklaDialog")
If db_Status = False Then
sSQL = "SELECT KURZNAME FROM sani97.dbo.Filiale Order By FilialeNr "
sConnect = "DSN=sani97;" & _
"UID=sani_user;" & _
"PWD=sani97;" & _
"IFSN=sani97sql;" & _
"DB=sani97;" & _
"applicationname=REKLA-EXCEL"
'On Error GoTo Login_Error
db.Open sConnect
db_Status = True
'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs.Open sSQL, sConnect, adOpenKeyset, adLockReadOnly, adCmdText
'Überprüfung ob Daten zurückgeliefert wurden
If Not rs.EOF And rs.RecordCount > 0 Then
filialeKurz = rs.GetRows
anzahlDS = rs.RecordCount
'MsgBox "Anzahl an Datensätzen = " & anzahlDS
With diag.DropDowns("ddn_auswahlFiliale")
.ListFillRange = anzahlDS - 1
.DropDownLines = 20
For i = 0 To anzahlDS - 1
.AddItem CStr(filialeKurz(0, i))
'ThisWorkbook.DialogSheets("ReklaDialog").DropDowns(2).AddItem (filialeKurz(0, 1))
Next
End With
Else
MsgBox "Keine Daten zu der Vorgangsnumemr in SaniVision gefunden.", vbCritical
Exit Sub
End If
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
db_Status = False
Else
MsgBox "Es existiert bereits eine Datenbankverbindung zu SaniViison.", vbInformation
Exit Sub
End If
Exit Sub
Login_Error:
MsgBox "Error #: " & Err.Number & " : Es konnte keine Verbindung zu SaniVision hergestellt werden. Bitte wenden Sie sich an Ihren Administrator.", vbCritical
End Sub
Sub FindeTabellenblatt(db_Status As Boolean, NameAuswlFil As String, abwFil As Integer, vorgangsNr As Long, RechnungsNr As Variant)
Const adOpenForwardOnly As Long = 0
Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim db As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim rs1 As New ADODB.Recordset
Dim rs2 As New ADODB.Recordset
Dim rs3 As New ADODB.Recordset
Dim sConnect As String
Dim anzahlDS As Integer
Dim sSQL As String
Dim sSQL1 As String
Dim sSQL2 As String
Dim sSQL3 As String
Dim rsfilialeNr
Dim rsabwfilialeNr
Dim rsKunde
Dim rsKTR
Dim filialeNr As String
Dim abwfilialeNr As String
Dim kunde As String
Dim ktr As String
Dim Filiale_vorhanden As Boolean
Dim diag As Object
Dim i As Integer
Set diag = DialogSheets("ReklaDialog")
' Es soll eine abweichende Filiale zum Vorgang genommen werden
sSQL = "SELECT FilialeNr FROM sani97.dbo.Filiale WHERE KURZNAME = '" & NameAuswlFil & "' "
' Es soll die Filiale des Vorgangs genommen werden
sSQL1 = "SELECT FilialeNr FROM sani97.dbo.Vorgang WHERE VorgangNr = " & vorgangsNr
' Ermitelt den Kunden zum Vorgang
sSQL2 = "SELECT NAME1, NAME2, KundenNr FROM sani97.dbo.Kunden WHERE KundenNr = (SELECT KundenNr FROM sani97.dbo.Vorgang WHERE dbo.Vorgang.VorgangNr = " & vorgangsNr & ")"
'sSQL2 = "SELECT kd.NAME2, kd.NAME1, ktr.NAME1, ktr.NAME2 FROM sani97.dbo.Kunden kd, sani97.dbo.Kostentraeger ktr WHERE kd.KundenNr = (SELECT vor.KundenNr FROM sani97.dbo.Vorgang vor WHERE vor.VorgangNr = " & vorgangsNr & ") AND kd.KKNr = ktr.KTNr"
' Ermittlung des Kostenträgers zur Rechnungsnummer
sSQL3 = "SELECT ktr.NAME1, ktr.NAME2 FROM sani97.dbo.Rechnung rg, sani97.dbo.Kostentraeger ktr WHERE rg.KTNr = ktr.KTNr AND rg.RechnungNr = " & RechnungsNr
anzahlDS = 0
If db_Status = False Then
If NameAuswlFil <> "" Then
sConnect = "DSN=sani97;" & _
"UID=sani_user;" & _
"PWD=sani97;" & _
"IFSN=sani97sql;" & _
"DB=sani97;" & _
"applicationname=REKLA-EXCEL"
'On Error GoTo Login_Error
db.Open sConnect
db_Status = True
'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs.Open sSQL, sConnect, adOpenKeyset, adLockReadOnly, adCmdText
' Überprüfung ob Daten zurückgeliefert wurden
If Not rs.EOF And rs.RecordCount > 0 Then
rsfilialeNr = rs.GetRows
filialeNr = rsfilialeNr(0, 0)
Filiale_vorhanden = istTabellenblatt_vorhanden(filialeNr)
If Filiale_vorhanden = True Then
'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs1.Open sSQL1, sConnect, adOpenKeyset, adLockReadOnly, adCmdText
' Überprüfung ob Daten zurückgeliefert wurden
If Not rs1.EOF And rs1.RecordCount > 0 Then
rsabwfilialeNr = rs1.GetRows
anzahlDS = rs1.RecordCount
abwfilialeNr = "(" & rsabwfilialeNr(0, 0) & ")"
'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs2.Open sSQL2, sConnect, adOpenKeyset, adLockReadOnly, adCmdText
If Not rs2.EOF And rs2.RecordCount > 0 Then
rsKunde = rs2.GetRows
kunde = rsKunde(1, 0) & ", " & rsKunde(0, 0) & " (" & rsKunde(2, 0) & ")"
'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs3.Open sSQL3, sConnect, adOpenKeyset, adLockReadOnly, adCmdText
If Not rs3.EOF And rs3.RecordCount > 0 Then
rsKTR = rs3.GetRows
ktr = rsKTR(0, 0) & " " & rsKTR(1, 0)
TabellenblattFilaleBearbeiten filialeNr, vorgangsNr, abwfilialeNr, RechnungsNr, kunde, ktr
'Sheets(filialeNr(0, 0)).Select
Else
MsgBox "Es wurde kein Kostenträger zur Rechnung " & RechnungsNr & " gefunden (evtl. falsche RechnungsNr). Bitte in SaniVision überprüfen.", vbInformation
End If
rs3.Close
Else
MsgBox "Es wurde kein Kunde zu diesem Vorgang gefunden. Bitte in SaniVision überprüfen.", vbInformation
rs2.Close
End If
rs2.Close
Else
MsgBox "Die abweichenden Filiale " & abwfilialeNr & " wurde in SaniVision nicht gefunden.", vbInformation
End If
Else
MsgBox "Für die Filiale " & filialeNr & " ist noch kein Tabellenblatt angelegt. Bitte anlegen, damit dieses gefüllt werden kann.", vbInformation
Exit Sub
End If
Else
MsgBox "Die Filiale " & filialeNr & " wurde in SaniVision nicht gefunden.", vbInformation
End If
rs1.Close
Else
sConnect = "DSN=sani97;" & _
"UID=sani_user;" & _
"PWD=sani97;" & _
"IFSN=sani97sql;" & _
"DB=sani97;" & _
"applicationname=REKLA-EXCEL"
'On Error GoTo Login_Error
db.Open sConnect
db_Status = True
'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs1.Open sSQL1, sConnect, adOpenKeyset, adLockReadOnly, adCmdText
' Überprüfung ob Daten zurückgeliefert wurden
If Not rs1.EOF And rs1.RecordCount > 0 Then
rsfilialeNr = rs1.GetRows
filialeNr = rsfilialeNr(0, 0)
abwfilialeNr = ""
Filiale_vorhanden = istTabellenblatt_vorhanden(filialeNr)
If Filiale_vorhanden = True Then
'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs2.Open sSQL2, sConnect, adOpenKeyset, adLockReadOnly, adCmdText
If Not rs2.EOF And rs2.RecordCount > 0 Then
rsKunde = rs2.GetRows
kunde = rsKunde(1, 0) & ", " & rsKunde(0, 0) & " (" & rsKunde(2, 0) & ")"
'Erzeugen des Recordsets - hier befinden sich dann die anzuzeigenden Daten
rs3.Open sSQL3, sConnect, adOpenKeyset, adLockReadOnly, adCmdText
If Not rs3.EOF And rs3.RecordCount > 0 Then
rsKTR = rs3.GetRows
ktr = rsKTR(0, 0) & " " & rsKTR(1, 0)
TabellenblattFilaleBearbeiten filialeNr, vorgangsNr, abwfilialeNr, RechnungsNr, kunde, ktr
'Sheets(filialeNr(0, 0)).Select
Else
MsgBox "Es wurde kein Kostenträger zur Rechnung " & RechnungsNr & " gefunden (evtl. falsche RechnungsNr). Bitte in SaniVision überprüfen.", vbInformation
End If
rs3.Close
Else
MsgBox "Es wurde kein Kunde zu diesem Vorgang gefunden. Bitte in SaniVision überprüfen.", vbInformation
End If
rs2.Close
Else
MsgBox "Für die Filiale " & filialeNr & " ist noch kein Tabellenblatt angelegt. Bitte anlegen, damit dieses gefüllt werden kann.", vbInformation
End If
'Sheets(filialeNr(0, 0)).Select
Else
MsgBox "Keine Daten zu der Vorgangsnummer in SaniVision gefunden.", vbCritical
End If
rs1.Close
End If
db.Close
Set rs = Nothing
Set rs1 = Nothing
Set rs2 = Nothing
Set db = Nothing
db_Status = False
Else
MsgBox "Es existiert bereits eine Datenbankverbindung zu SaniViison. Bitte beenden Sie Excel und starten Sie es neu.", vbInformation
Exit Sub
End If
Exit Sub
Login_Error:
MsgBox "Error #: " & Err.Number & " : Es konnte keine Verbindung zu SaniVision hergestellt werden. Bitte wenden Sie sich an Ihren Administrator.", vbCritical
End Sub
Function istTabellenblatt_vorhanden(TBvorhName As String)
Dim a As Integer
For a = 1 To Sheets.Count
If Sheets(a).Name = TBvorhName Then
istTabellenblatt_vorhanden = True
Exit Function
End If
Next a
istTabellenblatt_vorhanden = False
'Sheets("Muster").Select
'Sheets("Muster").Copy Before:=Sheets(6)
'ActiveSheet.Name = "Jahr"
End Function
Sub TabellenblattFilaleBearbeiten(TBName As String, TBVorgangsNr As Long, abwTBName As String, TBRechnungsNr As Variant, TBKunde As String, TBKTR As String)
Dim objCell
Dim objrange As Range
Dim objsheet As Worksheet
Dim objworkbook As Workbook
Set objworkbook = Application.Workbooks("REKLA 2021.xls")
Set objsheet = objworkbook.Sheets(TBName)
Dim diag As Object
Dim mytxfreklamBetrag As Object
Dim letztegefZeile As Integer
Dim letzteReklaNr As String
Dim intletzteReklaNr As Integer
Dim naechsteReklaNr As String
Dim intnaechsteReklaNr As Integer
Dim reklaBetrag As Currency
Dim i As Integer
Set diag = DialogSheets("ReklaDialog")
Set mytxfreklamBetrag = diag.EditBoxes("txf_reklamBetrag")
If bekommeBlattvomCodeName(TBName, objsheet, Workbooks("REKLA 2021.xls")) Then
'MsgBox "WS CodeName = " & ws.CodeName & " WS Name = " & ws.Name
'Sheets(TBName).Select
'Hier wir die letzte beschriebene Zeile der Spalte A ermittelt
'letztegefZeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
With Workbooks("REKLA 2021.xls").Worksheets(TBName)
letztegefZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
letzteReklaNr = .Cells(letztegefZeile, 1)
End With
If letztegefZeile = 3 Then
naechsteReklaNr = abwTBName & "/001"
Else
'MsgBox "letzte, befüllte Zelle = " & letztegefZeile
'MsgBox "letzte Rekla-Nr. = " & letzteReklaNr
intletzteReklaNr = CInt(Right(Trim(letzteReklaNr), 3))
intnaechsteReklaNr = intletzteReklaNr + 1
naechsteReklaNr = abwTBName & "/" & Format(intnaechsteReklaNr, "000")
End If
If (mytxfreklamBetrag.Text <> "") Then
reklaBetrag = CCur(mytxfreklamBetrag.Text)
Else
MsgBox "Bitte geben Sie den zu reklamierenden Betrag ein.", vbInformation
Exit Sub
End If
'MsgBox "naechste Rekla-Nr. = " & naechsteReklaNr
With Workbooks("REKLA 2021.xls").Worksheets(TBName)
.Cells(letztegefZeile + 1, 1).Value = naechsteReklaNr
.Cells(letztegefZeile + 1, 2).Value = reklaBetrag
.Cells(letztegefZeile + 1, 3).Value = TBVorgangsNr
.Cells(letztegefZeile + 1, 8).Value = TBKTR
.Cells(letztegefZeile + 1, 9).Value = TBKunde
.Cells(letztegefZeile + 1, 10).Value = TBRechnungsNr
.Cells(letztegefZeile + 1, 11).Value = Date
.Cells(letztegefZeile + 1, 12).Value = DateSerial(Year(Date), Month(Date) + 1, Day(Date))
End With
ActiveWorkbook.RefreshAll
ActiveWorkbook.Save
'Workbooks("REKLA 2015.xls").Worksheets(TBName).Cells(letztegefZeile + 1, 1).Value = naechsteReklaNr
Else
MsgBox "Das Arbeitsblatt wurde nicht in der Arbeitsmappe gefunden.", vbInformation
End If
End Sub
Es geht inspliziet um die Sub btn_StatusSetzen_Klicken()
|