AW: Textmarken werden nicht angesprungen
10.04.2008 20:38:15
Tino
Hallo,
habe mir den Code mal angesehen und habe mal die Deklarierung auf Word eingefügt.
Ob all die anderen Deklarierungen und Zuweisungen korrekt sind habe ich jetzt nicht geprüft.
Denke daran den Verweis auf Microsoft Word 11.0 Object zu aktivieren.
Ob der Code jetzt durchläuft kann ich nicht sagen, versuche es einfach mal.
Option Explicit
Dim RangeObj As Word.Range
Dim WordObj As Word.Application
Dim DocObj As Word.Document
Private Sub Userform_Initialize()
'Variablendeklaration
Dim intI, intS, intZ, d As Integer
Dim intActTag, intActMonat, intActJahr As Integer
Dim strErsteller As String
Dim strProjektleiter As String
Dim strProjektnummer As String
'Feststellen des aktuellen Datums
intActTag = Day(Date)
intActMonat = Month(Date)
intActJahr = Year(Date)
'Befüllen der Combobox "Ersteller"
intS = 10 'Spaltennummer
intZ = 48 ' Zeilennummer
With Worksheets("Basisdaten und Erklärung")
Do
strErsteller = .Cells(intZ, intS)
With cboErsteller
.AddItem strErsteller
intZ = intZ + 1
End With
Loop Until strErsteller = ""
cboErsteller.Value = "Bitte wählen Sie"
End With
'Befüllen der Combobox "Tag"
With cboTag
For intI = 1 To 31
.AddItem intI & "."
Next intI
.ListIndex = intActTag - 1
End With
'Befüllen der Combobox "Monat"
With cboMonat
.AddItem "Januar"
.AddItem "Febuar"
.AddItem "März"
.AddItem "April"
.AddItem "Mai"
.AddItem "Juni"
.AddItem "Juli"
.AddItem "August"
.AddItem "September"
.AddItem "Oktober"
.AddItem "November"
.AddItem "Dezember"
.ListIndex = intActMonat - 1
End With
'Befüllen der Textbox "Jahr"
txtJahr.Value = intActJahr
'Befüllen der Combobox "KW"
d = KW(Date)
With cboKW
For intI = 1 To 52
.AddItem intI
Next intI
.Value = d
End With
'Befüllen der Combobox Projektnummer
intS = 2 'Spaltennummer
intZ = 48 ' Zeilennummer
With Worksheets("Basisdaten und Erklärung")
Do
strProjektnummer = .Cells(intZ, intS)
With cboProjektnummer
.AddItem strProjektnummer
intZ = intZ + 1
End With
Loop Until strProjektnummer = ""
cboProjektnummer.Value = "Bitte wählen Sie"
End With
End Sub
Function KW(d As Date) As Integer
Dim t As Date
t = DateSerial(Year(d + (8 - Weekday(d)) Mod 7 - 3), 1, 1)
KW = (d - t - 3 + (Weekday(t) + 1) Mod 7) \ 7 + 1
End Function
Private Sub cboProjektnummer_AfterUpdate()
'Variablendeklaration
Dim intI, intA, intB, intS, intZ As Integer
Dim intActTag, intActMonat, intActJahr As Integer
Dim strNummer, strKW, strKWold As String
Dim strText As String
Dim strProjektnummer, Listennummer As String
'Auslesen der Projektnummern und KW
With Me
strProjektnummer = .cboProjektnummer.Value
strKW = "KW" & .cboKW.Value
End With
'Suchen und Eintragen der fehlenden Daten
intS = 2 'Spaltennummer
intZ = 48 ' Zeilennummer
With Worksheets("Basisdaten und Erklärung")
Do
strNummer = .Cells(intZ, intS)
intZ = intZ + 1
Loop Until strProjektnummer = strNummer
txtProjektleiter.Value = .Cells(intZ - 1, intS + 6)
txtBezeichnung.Value = .Cells(intZ - 1, intS + 1)
txtProjektleiter.SetFocus
End With
'Eintrag der Historie
strKWold = "KW" & Me.cboKW.Value - 1
If strKWold = "KW0" Then
Exit Sub
End If
With Worksheets(strKWold)
.Activate
intZ = 2
intS = 3
Do
intZ = intZ + 1
Listennummer = .Cells(intZ, intS)
Loop Until strProjektnummer = Listennummer
txtGestern.Value = .Cells(intZ, intS + 7)
txtHeute.Value = .Cells(intZ, intS + 8)
End With
Worksheets("Basisdaten und Erklärung").Activate
End Sub
Private Sub cmdExit_Click()
Variablendeklaration
Dim strErsteller, StrProjektNr, strProjektleiter, StrProjekttext, strGestern, strHeute, _
strMorgen As String
Dim strTag, strMonat, strJahr, strDatum, strTabelle, strKW, Listennummer As String
Dim strDatei, StrVerzeichnis, StrPfad, strDateiname, strPfadname, KWgestern As String
Dim intZeile, intSpalte, intKW As Integer
Dim bolPrint, bolMail As Boolean
Dim Kosten, Termine, Technik As String
'Werte den Variablen zuweisen
strErsteller = cboErsteller
strTag = cboTag
strMonat = cboMonat
strJahr = txtJahr
strDatum = strTag & " " & strMonat & " " & strJahr
intKW = cboKW
strKW = "KW" & intKW
KWgestern = "KW" & intKW - 1
StrProjektNr = cboProjektnummer
strProjektleiter = txtProjektleiter
StrProjekttext = txtBezeichnung
If optKgruen Then
Kosten = "grün"
ElseIf optKgelb Then
Kosten = "gelb"
ElseIf optKrot Then
Kosten = "rot"
Else: MsgBox "Sie haben keine Kostenbewertung abgegeben!", vbOKOnly + vbCritical
Exit Sub
End If
If optTgruen Then
Termine = "grün"
ElseIf optTgelb Then
Termine = "gelb"
ElseIf optTrot Then
Termine = "rot"
Else: MsgBox "Sie haben keine Terminbewertung abgegeben!", vbOKOnly + vbCritical
Exit Sub
End If
If optTechgruen Then
Technik = "grün"
ElseIf optTechgelb Then
Technik = "gelb"
ElseIf optTechrot Then
Technik = "rot"
Else: MsgBox "Sie haben keine technische Bewertung abgegeben!", vbOKOnly + vbCritical
Exit Sub
End If
strGestern = txtGestern
strHeute = txtHeute
strMorgen = txtMorgen
If optDja Then
bolPrint = True
End If
If optEJa Then
bolMail = True
End If
'Werte in die passende KW eintragen
strTabelle = strKW
Unload Me
intZeile = 2
intSpalte = 3
With Worksheets(strTabelle)
.Activate
'passende Projektnummer suchen
Do
intZeile = intZeile + 1
Listennummer = .Cells(intZeile, intSpalte)
Loop Until StrProjektNr = Listennummer
.Cells(intZeile, 1) = strErsteller
.Cells(intZeile, 2) = strDatum
.Cells(intZeile, 4) = strProjektleiter
.Cells(intZeile, 5) = StrProjekttext
.Cells(intZeile, 6) = Kosten
.Cells(intZeile, 7) = Termine
.Cells(intZeile, 8) = Technik
.Cells(intZeile, 9) = strGestern
.Cells(intZeile, 10) = strHeute
.Cells(intZeile, 11) = strMorgen
End With
With Worksheets("Basisdaten und Erklärung")
.Activate
End With
'Projektmatrix bewerten
intZeile = 1
intSpalte = 2
With Worksheets("Projektmatrix")
.Activate
'passende Projektnummer suchen
Do
Listennummer = .Cells(intZeile, intSpalte)
intSpalte = intSpalte + 3
Loop Until StrProjektNr = Listennummer
intSpalte = intSpalte - 3
intZeile = intKW + 4
.Cells(intZeile, intSpalte) = Kosten
.Cells(intZeile, intSpalte + 1) = Termine
.Cells(intZeile, intSpalte + 2) = Technik
End With
With Worksheets("Basisdaten und Erklärung")
.Activate
End With
'Erstellung des Wochenberichts als Word-Dokument
Dim WordObj As Word.Application
Dim DocObj As Word.Document
StrPfad = ThisWorkbook.Path
strDateiname = StrPfad & "\" & "weekly report.dot"
Set WordObj = CreateObject("Word.Application")
Set DocObj = WordObj.Documents.Open(Filename:=strDateiname, ReadOnly:=True)
WordObj.Visible = True
WordObj.Application.Activate
Call WriteInBookmark("KW", strKW)
Call WriteInBookmark("Ersteller", strErsteller)
Call WriteInBookmark("Datum", strDatum)
Call WriteInBookmark("Projektnummer", StrProjektNr)
Call WriteInBookmark("Projektthema", StrProjekttext)
Call WriteInBookmark("Verantwortlicher", strProjektleiter)
Call WriteInBookmark("Kosten", Kosten)
Call WriteInBookmark("Termine", Termine)
Call WriteInBookmark("Technik", Technik)
Call WriteInBookmark("KWgestern", KWgestern)
Call WriteInBookmark("Gestern", strGestern)
Call WriteInBookmark("Heute", strHeute)
Call WriteInBookmark("Morgen", strMorgen)
'Ausdruck
If bolPrint = True Then
'WordObj.PrintOut
End If
'Ablage des Wochenberichts
If bolMail = True Then GoTo Mail
strDatei = "Wochenbericht " & strKW & " " & StrProjektNr & ".doc"
StrVerzeichnis = strKW
strPfadname = StrPfad & "\" & strJahr & "\" & StrVerzeichnis & "\" & strDatei
DocObj.SaveAs Filename:=strPfadname
'Mailversand der DocDatei
Mail:
With WordObj.Application
'.DisplayAlerts = False
'.Quit
End With
Set WordObj = Nothing
End Sub
Private Sub WriteInBookmark(ByVal BMName As String, ByVal BMText As String)
'Schreibt einen neuen Wert in ein vorhandenes Bookmark
With DocObj
If .Bookmarks.Exists(BMName) Then
Set RangeObj = .Bookmarks(BMName).Range
RangeObj.Text = BMText
.Bookmarks.Add Name:=BMName, Range:=RangeObj
Set RangeObj = Nothing
Else
MsgBox BMName & " existiert nicht", vbCritical + vbOKOnly
End If
End With
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
Gruß
Tino
