AW: ereignisse werden nicht ausgelöst - Nachtrag
05.02.2005 14:11:38
Marco
Hi Stefan & Björn,
danke für Eure Hilfsbereitschaft. Das gesamte Projekt ist mehrere MB gross, dehalb hier nur mal das Blatt, das Probleme macht + aufgerufene Fkt. (ganz unten):
Option Explicit
Dim mWB As Workbook
Dim mWS As Worksheet
Dim WithEvents wsscen As Worksheet
Dim intScenarioID As Integer
Private Const strThisSheet As String = strEinzelansichtSheetname
Private Sub Worksheet_Activate()
Dim rngScens As Range
Set mWB = ThisWorkbook
Set mWS = mWB.Sheets(strThisSheet)
Set wsscen = mWB.Sheets(strScenariosSheetname)
Set rngScens = wsscen.Cells(2, 4)
Set rngScens = wsscen.Range(rngScens, rngScens.End(xlDown))
'listfillrange mit used range setzen
lstSzenarien.ListFillRange = rngScens
'LoadScenarios (lstSzenarien)
'If Not (LoadScenarios(lstSzenarien)) Then
' MsgBox "Fehler beim Laden der Szenarien.", vbExclamation, "Ladefehler"
' Exit Sub
If Not (LoadProjects(GetSIDFromListIndex(lstSzenarien), cmbProjects)) Then MsgBox "Fehler beim Laden der Projekte", vbExclamation, "Ladefehler"
cmbProjects.ListIndex = -1
'End If
End Sub
'###################################
Public Sub lstszenarien_Change()
UpdateControls
' LoadProjects GetSIDFromListIndex(lstSzenarien), cmbProjects
End Sub
'###################################
Private Sub cmbProjects_Click()
LoadProjects GetSIDFromListIndex(lstSzenarien), cmbProjects
End Sub
Private Sub cmdShowCashFlow_Click()
ReadProjectDetails GetSIDFromListIndex(lstSzenarien), GetPIDFromComboBox(cmbProjects)
End Sub
Private Sub cmdWriteCashFlow_Click()
'details aus der einzelansicht in Datenbasis speichern
WriteProjectDetails GetSIDFromListIndex(lstSzenarien), GetPIDFromComboBox(cmbProjects)
End Sub
'###################################
Private Sub wsscen_Change(ByVal Target As Range)
If Not IsEmpty(lstSzenarien) Then LoadScenarios (lstSzenarien)
End Sub
'###################################
Private Sub UpdateControls()
Dim intSID As Integer
Dim intPID As Integer
intSID = GetSIDFromListIndex(lstSzenarien)
If intSID = 0 Then
MsgBox "Ungültiges Szenario ausgewählt.", vbInformation, "Ladefehler"
Exit Sub
End If
intPID = GetPIDFromComboBox(cmbProjects)
If Not LoadProjects(intSID, cmbProjects) Then
MsgBox "Fehler beim Laden der Projekte", vbInformation, "Ladefehler"
Exit Sub
ElseIf intPID = 0 Then Exit Sub
ElseIf Not ReadProjectDetails(intSID, intPID) Then
MsgBox "Das Projekt konnte unter diesem Szenario nicht geladen werden." _
& " Eventuell ist es unter diesem Szenario nicht vorhanden.", vbInformation, "Projekt wurde nicht geladen"
'MsgBox "Das Projekt existiert unter diesem Szenario noch nicht!" _
' & "Falls nötig, erstellen Sie das Projekt bitte im Projektformular", vbInformation, "Projekt nicht existent"
Exit Sub
End If
End Sub
'###################################################
Public Function ReadProjectDetails(intSID As Integer, intPID As Integer) As Integer
'liest die details eines projektes aus der datenbasis aus
Dim rngSelected As Range
Dim ws As Worksheet
Dim projs As New Projects
Dim pview As ProjectView
Dim rngsrc As Range
Dim rngdest As Range
Dim r As Range
Application.ScreenUpdating = False
Set ws = Worksheets(strProjectsSheetname)
Set pview = projs.FindView(intSID, intPID)
If pview Is Nothing Then
ReadProjectDetails = -1
Exit Function
End If
Set r = pview.startrow
'Set rng = Worksheets(strThisSheet)
Set rngsrc = r
Set rngdest = ThisWorkbook.Sheets(strEinzelansichtSheetname).rows(8)
Set rngdest = Range(rngdest, rngdest.Offset(intanzahlrows - 1))
'Set rngdest = ws.Range(Cells(8, 1), Cells(8, 1).Offset(intanzahlrows - 1))
Do Until r.row = pview.endrow.row
Set rngsrc = Union(rngsrc, r)
Set r = r.Offset(1, 0)
Loop
'blattschutz aufheben
ThisWorkbook.Sheets(strEinzelansichtSheetname).Unprotect
'aktive markierung merken, um sie später wieder zu setzen
Set rngSelected = Application.ActiveCell
'kopieren
rngsrc.Copy rngdest
'optimale breite der spalten einstellen
rngdest.EntireColumn.Columns.AutoFit
'freien bereich wieder ausblenden
Dim i As Integer
'oberer bereich
For i = 1 To intanzahlfreierowsoben
rngdest.Select
rngdest.Cells(i, 1).EntireRow.Hidden = True
Next i
'linker bereich
For i = 1 To intanzahlfreierowslinks
rngdest.Select
rngdest.Cells(, i).EntireColumn.Hidden = True
Next i
'unteren bereich grau färben
For i = 1 To intanzahlfreierowsunten
rngdest.Cells(i, 1).EntireRow.Interior.ColorIndex = 15
Next i
'vorige auswahl wieder setzen
rngSelected.Select
'blatt wieder schützen
'ThisWorkbook.Sheets(strEinzelansichtSheetname).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
ReadProjectDetails = 1
End Function
'##############################################
Public Sub WriteProjectDetails(intSID As Integer, intPID As Integer)
'schreib details eines projektes in die datenbasis
Dim ws As Worksheet
Dim projs As New Projects
Dim pview As ProjectView
Dim rngsrc As Range
Dim rngdest As Range
Dim r As Range
Dim oldCalc As XlCalculation
'berechnung umstellen
oldCalc = Application.Calculation
Application.Calculation = xlCalculationManual
Set ws = Worksheets(strProjectsSheetname)
Set pview = projs.FindView(intSID, intPID)
If pview Is Nothing Then
MsgBox "Es konnte nicht gespeichert werden.", vbExclamation, "Speichern fehlgeschlagen"
Exit Sub
End If
Set r = pview.startrow
'Set rng = Worksheets(strThisSheet)
Set rngdest = r
Set rngsrc = ThisWorkbook.Sheets(strEinzelansichtSheetname).rows(8)
Set rngsrc = Range(rngsrc, rngsrc.Offset(intanzahlrows - 1))
'Set rngdest = ws.Range(Cells(8, 1), Cells(8, 1).Offset(intanzahlrows - 1))
Do Until r.row = pview.endrow.row
Set rngdest = Union(rngdest, r)
Set r = r.Offset(1, 0)
Loop
rngsrc.Copy rngdest
Application.Calculation = oldCalc
'rngdest.PasteSpecial
End Sub
'##########################################
'Code Ende
Jedes Mal, wenn ich die ListBox neu erstelle, dann triggert er das _Activate-Ereignis genau einmal. Ich sehe allerdings nicht, wo der Code die Box in ihren Eigenschaften verändert, abgesehen vom Einlesen der Werte.
Hoffe, es ist einigermaßen verständlich.
Marco