Bekomme irgendwie nicht den Zugriff auf...
21.12.2011 20:45:38
KLE
das Array1.
Hi Rudi und alle anderen ;o)
...habe nun meinen Einlese-Code im Modul geschrieben und dieser lässt sich auch von der UF starten.
Nur, wenn ich im weiteren Code in der Userform auf das Array was im Modul erstellt wurde zugreifen will, erhalte ich stets die Fehlermeldung: "Außerhalb des Bereichs"
Habe hier ein Versuch mit dem Import aus Outlook...
Hier der Code aus dem Modul:
Option Explicit
Dim z As Long, a As Long, x As Long, p As Long, PBMAx As Long, LZeile As Long, i As Long
Dim u As Long
Dim txtKID As String, wksDBK As Worksheet, txtSuche As String
Dim arrKAG(), arrLBOut(), arrKAbG(), arrFilter()
' Outlook-Import
Dim objOutlook As Object, objItem As Object, ContactFolder As Object, objnSpace As Object
Dim objFolder As Object, WorkingFolder As Object, oCon As Object, objOutRun
Dim olMAPI As New Outlook.Application
Dim arrListOut(), arrOutIm()
Dim Abbruch As Boolean
' Outlook-Kontakte einlesen, mit vorhanden abgleichen und darstellen
Public Sub OK_einlesen(WorkingFolder)
Set wksDBK = Worksheets("DBK")
UFDaten.objLAbbruch.Caption = "NEIN"
p = 0
' Array vorbereiten, wenn ein Ordner ausgewählt wurde
Set WorkingFolder = WorkingFolder
If Not WorkingFolder Is Nothing Then
For i = 1 To WorkingFolder.Items.Count
' Datensatz prüfen, ob es sich um ein kontakt handelt
If WorkingFolder.Items(i).Class = olContact Then p = p + 1
Next i
If p = 0 Then
MsgBox "Kein Kontaktordner ausgewählt!", vbOKOnly, "Auswahlfehler"
UFDaten.objLAbbruch.Caption = "Ja"
GoTo Ende
End If
UFDaten.objLImportPfad.Caption = WorkingFolder.Name
ReDim arrLBOut(28, (WorkingFolder.Items.Count))
' Statusbar - Infos
UFDaten.objPBStatus.Visible = True
UFDaten.objPBStatus.Value = 0
PBMAx = wksDBK.Cells(Rows.Count, 1).End(xlUp).Row - 1
UFDaten.objPBStatus.Min = 0
UFDaten.objPBStatus.Max = PBMAx
x = 0
' Kundenliste aus wksDBK für den Abgleich erstellen
With wksDBK
z = 0
For a = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
ReDim Preserve arrKAbG(3, 0 To a - 2)
ReDim Preserve arrFilter(0 To a - 2)
arrKAbG(0, z) = a - 1 ' Zähler
arrKAbG(1, z) = VBA.Trim(.Cells(a, 8).Value & _
.Cells(a, 7).Value & .Cells(a, 10).Value)
arrKAbG(2, z) = .Cells(a, 2).Value ' KID
' Sucharray
arrFilter(z) = VBA.Trim(.Cells(a, 8).Value & _
.Cells(a, 7).Value & .Cells(a, 10).Value)
z = z + 1
UFDaten.objPBStatus.Value = z
Next a
End With
' alle Kontakte in ein Array lesen
'############################################################################################### _
' Statusbar - Infos
UFDaten.objPBStatus.Visible = True
UFDaten.objPBStatus.Value = 0
PBMAx = WorkingFolder.Items.Count
UFDaten.objPBStatus.Min = 0
UFDaten.objPBStatus.Max = PBMAx
x = 0
For i = 1 To WorkingFolder.Items.Count
' Prüfen, ob Einträg überhaupt ein Typ Kontakt ist (kein Verteiler, Gruppe etc.)
If WorkingFolder.Items(i).Class = olContact Then
'On Error Resume Next
Set oCon = WorkingFolder.Items(i)
' Suchindex
txtSuche = VBA.Trim(oCon.LastName & oCon.FirstName & oCon.CompanyName)
' Prüfen, ob bereits vorhanden
txtKID = "" ' KID leeren
For u = 0 To UBound(arrFilter)
If arrFilter(u) = txtSuche Then
LZeile = u
txtKID = arrKAbG(2, u)
End If
Next u
ReDim Preserve arrOutIm(28, 1 To i)
arrOutIm(0, i) = i ' Zähler
arrOutIm(1, i) = txtKID ' KID
arrOutIm(2, i) = oCon.Title ' Anrede
arrOutIm(3, i) = oCon.JobTitle ' Position (Berufsbezeichnung)
arrOutIm(4, i) = oCon.FirstName ' Vorname
arrOutIm(5, i) = oCon.LastName ' Name
If oCon.Birthday "01.01.4501" Then
arrOutIm(6, i) = oCon.Birthday ' Geburtstag
End If
arrOutIm(7, i) = oCon.CompanyName ' Firmenbezeichnung/Name
arrOutIm(8, i) = oCon.BusinessAddressStreet ' Strasse
arrOutIm(9, i) = oCon.BusinessAddressCountry ' Land
arrOutIm(10, i) = oCon.BusinessAddressPostalCode ' PLZ
arrOutIm(11, i) = oCon.BusinessAddressCity ' Ort
arrOutIm(12, i) = oCon.BusinessTelephoneNumber ' Telefon
arrOutIm(13, i) = oCon.Business2TelephoneNumber ' Telefon2
arrOutIm(14, i) = oCon.MobileTelephoneNumber ' Mobilfunk
arrOutIm(15, i) = oCon.BusinessFaxNumber ' Fax
arrOutIm(16, i) = oCon.Email1Address ' FirmenEmail
arrOutIm(17, i) = oCon.BusinessHomePage ' Firmenwebsite
arrOutIm(18, i) = oCon.Body ' Anmerkung/Bemerkung
' Privat-Daten
arrOutIm(19, i) = oCon.HomeAddressStreet ' Strasse
arrOutIm(20, i) = oCon.HomeAddressCountry ' Land
arrOutIm(21, i) = oCon.HomeAddressPostalCode ' PLZ
arrOutIm(22, i) = oCon.HomeAddressCity ' Ort
arrOutIm(23, i) = oCon.HomeTelephoneNumber ' Telefon
arrOutIm(24, i) = oCon.OtherTelephoneNumber ' Mobil (other Phone)
arrOutIm(25, i) = oCon.HomeFaxNumber ' FaxNummer
arrOutIm(26, i) = oCon.Email2Address ' Email
arrOutIm(27, i) = "" ' Photopfad - nicht Existenz
End If
' Info an User in Frame Import
UFDaten.objLOrdner.Caption = "Import von Kontakten aus dem augewählten Ordner: " & _
WorkingFolder.Name
UFDaten.objLInfo.Caption = i & " von " & WorkingFolder.Items.Count & " Kontakte wurden aus _
dem Ordner eingelesen."
UFDaten.objPBStatus.Value = i
Next i
'############################################################################################### _
End If
Set objItem = Nothing
Set olMAPI = Nothing
Set oCon = Nothing
Ende:
UFDaten.objPBStatus.Visible = False
End Sub
Hier der Code in der Userform:
Private Sub OutImport_Listboxfüllen(WorkingFolder As Object)
' Listbox leeren und einrichten
With objLBOIKontakte
.Clear
End With
'Daten einlesen
Call OK_einlesen(WorkingFolder)
If objLAbbruch.Caption = "Ja" Then GoTo Ende
' Array übergeben vom Import
arrLBOut = myTrans(arrOutIm) ' hier kommt die Fehlermeldung!
' Datenübetragen auf Listbox-Array (Outimport)
arrListImport = arrListOut
' Listbox leeren und einrichten
With objLBOIKontakte
.List = arrListImport
.ColumnCount = 28
.ColumnHeads = False
.ColumnWidths = "0;25;55;0;95;108;0;200;0;0;0;175;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0"
.Height = 355
.Width = 689
End With
' objFImES.Visible = False
Call AnzahlKontakte
Ende:
End Sub
Vielleicht kann mir hier jemand helfen ?!?
Gruß und Danke!
Kay