problem besteht noch --> jetzt kompletter code
20.02.2007 13:41:00
SteffenS
Hallo, hier nun mal der komplette Code der UF
Public lastma As Long 'letzten Mitarbeiter merken
Public hfkto As Long '-->Hilfskonto letztes Konto einlesen
Public stati_aut As Long 'Stati für automatisches Fortsetzen
Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindow Lib "User32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowRect Lib "User32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ReleaseCapture Lib "User32" () As Long
Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "User32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private FensterRegion&, Region&
Private Hauptfensternummer&, Clientfensternummer&
Private dummy As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const GW_CHILD = 5
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Sub FensterOhneKopf()
Dim Abmessung As RECT
Dim Abmessung1 As RECT
Dim Pos1x&, Pos1y&, Pos2x&, Pos2y&
If FensterRegion 0 Then Exit Sub
LGVert.BorderStyle = fmBorderStyleSingle
Call Fensternummer(LGVert, Abmessung, Abmessung1)
Pos1x = 0
Pos1y = (Abmessung1.Top - Abmessung.Top)
Pos2x = Abmessung.Right - Abmessung.Left
Pos2y = Abmessung.Bottom - Abmessung.Top
Region = CreateRectRgn(Pos1x, Pos1y, Pos2x, Pos2y)
FensterRegion = SetWindowRgn(Hauptfensternummer, Region, True)
End Sub
'Fensterhandles und Infos über Fenster holen
Private Sub Fensternummer(Form As Object, Abmessung As RECT, Abmessung1 As RECT)
Dim Fenstername$, Suchstring$
Suchstring = "Verteilung"
Fenstername = Form.Caption
Form.Caption = Suchstring
Hauptfensternummer = FindWindow(vbNullString, Suchstring)
Form.Caption = Fenstername
Clientfensternummer = GetWindow(Hauptfensternummer, GW_CHILD)
dummy = GetWindowRect(Hauptfensternummer, Abmessung)
dummy = GetWindowRect(Clientfensternummer, Abmessung1)
End Sub
'Folgendes ist notwendig, um die Form ohne Titelleiste zu verschieben
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
If Hauptfensternummer <> 0 Then
dummy = ReleaseCapture()
dummy = SendMessage(Hauptfensternummer, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End If
Else
'Unload LGVert ' Zum schließen, beim ausprobieren.
End If
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, _
CloseMode As Integer)
If CloseMode = 0 Then
Beep
Cancel = True
End If
End Sub
Private Sub UserForm_Initialize()
'Allgemein setzen
Set WSKS = Workbooks("07BLVallg.XLS").Sheets("KTO_St.") 'Matrix Kontensteuerung
Dim ktozaehler As Long
ktozaehler = 0
Dim kto_merke As String
'Stati rücksetzen
stati_aut = 0
'Letzen Mitarbeiter definieren
lastma = Workbooks(ThisWorkbook.Name).Sheets("Leer").Range("B2").Value
'letzte Hilfskontenspalte definieren
hfkto = Workbooks(ThisWorkbook.Name).Sheets("Leer").Range("C2").Value
'Abfrage ob neuer Mitarbeiter
If VertArt = 3 And lastma <> MA Then
hfkto = 35
ElseIf VertArt = 4 And lastma <> maV Then
hfkto = 35
ElseIf VertArt = 3 Or VertArt = 4 Then
'hfkto = 36
hfkto = Workbooks(ThisWorkbook.Name).Sheets("Leer").Range("C2").Value
'hfkto = hfkto + 1
Else
End If
'Mitarbeitername einsetzen
'On Error Resume Next
Set WSK = Workbooks("07BLV_" & month & ".xls").Sheets("KTO_Vert._Details") '--> Blatt Kontenverteilung
ma_name.Caption = WSK.Cells(ze_maname, 2).Value & " " & WSK.Cells(ze_maname, 3).Value
'Marke einsetzen
marke.Caption = markeueber
'aktuellen Bereich einsetzen
akt_bereich.Caption = bereich_vert
akt_bereich2.Caption = bereich_vert2
'%Anteil einsetzen
pr_anteil.Caption = pranteil_vert
'Konto erhöhen
hfkto = hfkto + 1
'Kontenbezeichnung einsetzen
For ma_h = 1 To 10
For Each mn In Me.Controls
If mn.Name Like "kto_" & ma_h Then
'Konten einsetzen
'MsgBox (WSKS.Cells(3, ma_h + 27).Value)
If WSKS.Cells(3, ma_h + 27).Value <> 0 And WSKS.Cells(3, ma_h + 27).Value <> "frei" Then
Me.Controls(mn.Name).Caption = WSKS.Cells(6, ma_h + 27).Value & " " & WSKS.Cells(3, ma_h + 27).Value & " " & WSKS.Cells(4, ma_h + 27).Value & " " & WSKS.Cells(5, ma_h + 27).Value
'Abfrage ob Verteilung möglich ist
'Abfrage nach Art der Verteilung (Planung, manuell)
If VertArt = 3 Then
If WSKS.Cells(berze, ma_h + 27).Value = "" Or WSKS.Cells(berze, ma_h + 27).Value = 0 Then
Me.Controls(mn.Name).Enabled = False
End If
If Cells(MA, hfkto).Value = WSKS.Cells(6, ma_h + 27).Value And Me.Controls(mn.Name).Enabled = True Then Me.Controls(mn.Name).Value = True
ElseIf VertArt = 4 Then
If WSKS.Cells(berV - 5, ma_h + 27).Value = "" Or WSKS.Cells(berV - 5, ma_h + 27).Value = 0 Then Me.Controls(mn.Name).Enabled = False
If Cells(maV, hfkto).Value = WSKS.Cells(6, ma_h + 27).Value And Me.Controls(mn.Name).Enabled = True Then Me.Controls(mn.Name).Value = True
End If
Else
Me.Controls(mn.Name).Caption = "Konto nicht belegt"
Me.Controls(mn.Name).Enabled = False
End If
'Zähler wegen automatischer Auswahl
If Me.Controls(mn.Name).Enabled = True Then kto_merke = mn.Name
If Me.Controls(mn.Name).Enabled = False Then
ktozaehler = ktozaehler + 1
End If
End If
Next
Next ma_h
'automatische Auswahl wenn nur ein Konto vorhanden ist
If ktozaehler = 9 Then
Me.Controls(kto_merke).Value = True
stati_aut = 1
Call fortsetzen_Click
Unload Me
Else
' Me.Controls(kto_merke).Value = False
End If
'Fenster setzen
Call FensterOhneKopf
End Sub
Private Sub info_01_Click()
'Mitarbeiterdetails anzeigen
ma_details
End Sub
Private Sub info_02_Click()
'Mitarbeiterdetails anzeigen
info_01_Click
End Sub
Private Sub fortsetzen_Click()
Dim zauswahl As Long '--> Zähler für Auswahlbox
zauswahl = 0
For ma_h = 1 To 10
For Each mn In Me.Controls
If (mn.Name Like "kto_" & ma_h) Then
If Me.Controls(mn.Name).Value = True Then
zauswahl = zauswahl + 1
'Kontonummerdefinieren
kto_name = Left(Me.Controls(mn.Name).Caption, 4)
End If
End If
Next
Next ma_h
'Beträge verteilen
If zauswahl = 0 Then
Fehler = MsgBox("Bitte wählen Sie ein Konto für die Verteilung aus!", vbInformation, "Bruttolohnverteilung")
Else
'Monat definieren
month = Workbooks("07BLVallg.XLS").Sheets("strg_werte").Range("D21").Value
Set WSPP = Workbooks("07BLV_" & month & ".xls").Sheets("man. Verteilung")
Set WSK = Workbooks("07BLV_" & month & ".xls").Sheets("KTO_Vert._Details") '--> Blatt Kontenverteilung
Set WSKS = Workbooks("07BLVallg.XLS").Sheets("KTO_St.") 'Matrix Kontensteuerung
Set WSB = Workbooks("07BLV_" & month & ".xls").Sheets("Lohn-Gehalt") '--> Blatt Betrag
'Planungsdatenübernahme aus TBx Dateien
If VertArt = 3 Then
If WSKS.Cells(berze, 28).Value = "" And WSKS.Cells(berze, 29).Value = "" And WSKS.Cells(berze, 32).Value = "" Then
GoTo Fehlerkto
Else
WSK.Cells(ktoa, 5).Value = kto_name
End If
'letztes Kto eintragen
Cells(MA, hfkto).Value = WSK.Cells(ktoa, 5).Value
Cells(MA, hfkto).NumberFormat = ";;;"
'letzten Mitarbeiter merken
Workbooks(ThisWorkbook.Name).Sheets("Leer").Range("B2").Value = MA
'letzte Hilfskontenspalte merken
Workbooks(ThisWorkbook.Name).Sheets("Leer").Range("C2").Value = hfkto
'letztes Konto merken
last_vert_kto = WSK.Cells(ktoa, 5).Value
'Planungsdatenübernahme aus manuellen Dateien
ElseIf VertArt = 4 Then
If WSKS.Cells(berV - 5, 28).Value = "" And WSKS.Cells(berV - 5, 29).Value = "" And WSKS.Cells(berV - 5, 32).Value = "" Then
GoTo Fehlerkto
Else
WSK.Cells(ktoaV, 5).Value = kto_name
End If
'letztes Kto eintragen
Cells(maV, hfkto).Value = WSK.Cells(ktoaV, 5).Value
Cells(maV, hfkto).NumberFormat = ";;;"
'letzten Mitarbeiter merken
Workbooks(ThisWorkbook.Name).Sheets("Leer").Range("B2").Value = maV
'letzte Hilfskontenspalte merken
Workbooks(ThisWorkbook.Name).Sheets("Leer").Range("C2").Value = hfkto
'letztes Konto merken
last_vert_kto = WSK.Cells(ktoaV, 5).Value
End If
'UF aus
If stati_aut = 0 Then Unload Me
'Änderungen ein
Application.ScreenUpdating = True
'Programm warten lassen
Application.Wait Now + TimeValue("00:00:02")
'Änderungen aus
Application.ScreenUpdating = False
End If
Exit Sub
Fehlerkto:
'Fehler bei leerem Konto
Fehler01 = MsgBox("Diese Verteilung ist nicht möglich!" & Chr(13) & Chr(13) & "Prüfen Sie gegebenenfalls die Kontenmatrix.", vbCritical, "Bruttolohnverteilung")
End Sub