.....listbox...........und mehr
14.05.2004 17:53:13
Sven
ich stehe vor folgendem Problem. Ich habe eine Liste mit Namen (ca. 200 Zeilen) und noch ein paar andere Spalten. Ich würde
nun gerne über eine userform abfragen, welcher Bereich "gedruckt" werden soll. Eigentlich sollen die Daten später nach Word
exportiert werden. Dazu wollte ich die Spalte mit den Namen durchgehen, die Namen und den Inhalt einer anderen Spalte in
einer Listbox darstellen , in der man dann die Namen auswählen kann, die man "weiterverarbeiten" möchte. Ich habe da schon
ein paar Ansätze gefunden und was damit angefangen, allerdings stcke ich irgendwie fest. Die Liste in der Listbox bleibt
leer. Warum auch immer. Ich meinen bisherigen Code mal unten angehängt. Da fehlt auch sonst noch so einiges und funktioniert
sonst noch eine Menge mehr nicht. Vielleicht kann mir jemand ersteinmal zu meinem oben geschilderten Problem helfen. Wenn
jemand noch weiter weiß, wäre ich nicht böse drum.
Würde mich freuen, wenn jemand kapeirt, was ich da vorhabe und vielleicht einen Fehler findet.
Vielen Dank schonmal.
Sven
Private Sub CoverGestalten()
Dim objWord As Object
Dim objBlatt As Worksheet
Dim intI As Integer
Dim strTitel As String
Dim strLänge As String
Dim strTitelliste As String
Dim iRow As Integer
Dim iloop As Integer
Dim anzahl_der_teilnehmer As Integer
Sheets("Tabelle1").Select
anzahl_der_teilnehmer = WorksheetFunction.Count(Sheets("Tabelle1").Range("b2:B65000").Value)
On Error Resume Next
'Listenfelddialog frmAuswahl aufrufen
With frmAuswahl
'Fenstertiteltext festlegen
.Caption = APP_NAME
'Eingabeaufforderungstext festlegen
.lblPrompt.Caption = "Wählen Sie den zu druckenden Bereich:"
'Listenfeld konfigurieren
With .lstListbox
'Zwei Spalten anlegen
.ColumnCount = 2
'Spaltenbreiten festlegen
.ColumnWidths = "-1;-1"
iloop = 0
iRow = 2
'Alle Spalten mit Namen durchlaufen
Sheets("Tabelle1").Select
Do
'Namen des Teilnehmers in erste Spalte schreiben
.List(.ListCount - 1, 1) = objBlatt.Cells(iRow, 1).Value
'Strecke des Teilnehmers in zweite Spalte schreiben
.List(.ListCount - 1, 2) = objBlatt.Cells(iRow, 2).Value
iRow = iRow + 1
iloop = iloop + 1
Loop While iloop < anzahl_der_teilnehmer
'Wenn Listenfeld leer ist, dann...
If .ListCount = 0 Then
'... Makro beenden
End
'Ansonsten...
Else
'... erstes Listenelement markieren
.ListIndex = 0
End If
End With
'Userform anzeigen
.Show
'Wenn Anwender 'Abbrechen' gewählt hat, dann...
If .Tag = "Abbruch" Then
'... Makro beenden
End
End If
End With
'Neue Instanz von Microsoft Word starten
Set objWord = CreateObject("Word.Application")
'Bei Misserfolg...
If objWord Is Nothing Then
'... Fehlermeldung ausgeben
MsgBox "Word kann nicht gestartet werden.", vbCritical, APP_NAME
'Bei Erfolg...
Else
With objWord
'Word sichtbar machen
.Visible = True
'Neues Dokument auf Grundlage von Urkunde.dot anlegen
.Documents.Add template:=.Options.DefaultFilePath(2) & "\Urkunde.dot"
'Bei Misserfolg...
If Err <> 0 Then
'... Fehlermeldung anzeigen
MsgBox "Bitte kopieren Sie die Dokumentvorlage Urkunde.dot in das folgende Verzeichnis: " & vbCr &
.Options.DefaultFilePath(2), vbCritical, APP_NAME
'Word schließen
.Quit
'Objektvariable freigeben
Set objWord = Nothing
'Makro beenden
End
End If
'Textmarken der Inlay-Tabelle durch Albuminfos ersetzen
Call WDTextmarkeFüllen(objWord, .ActiveDocument, "Vorname", ...............)
Call WDTextmarkeFüllen(objWord, .ActiveDocument, "Nachname", ...............)
Call WDTextmarkeFüllen(objWord, .ActiveDocument, "Strecke", ................)
End With
'Objektvariable für Word-Zugriff freigeben (Word bleibt geöffnet)
Set objWord = Nothing
End If
'Makro beenden und alle Userform-Dialogfeldinhalte zurücksetzen
End
End Sub
Private Sub WDTextmarkeFüllen(objWord As Object, objWDDokument As Object, strTMName As String, strTMWert As String)
'Wenn Textmarke existiert, dann...
If objWDDokument.Bookmarks.Exists(strTMName) = True Then
'... Textmarke markieren
objWDDokument.Bookmarks(strTMName).Range.Select
'Mit Inhalt überschreiben
objWord.Selection.Text = strTMWert
'Textmarke neu anlegen über neuem Inhalt
objWDDokument.Bookmarks.Add Range:=objWord.Selection.Range, Name:=strTMName
'Markierung aufheben
objWord.Selection.Collapse 0
End If
End Sub