starting row wijzingen in code

[marcfields]

Hoi allen,

Ik heb een macro VB code gemaakt om e-mails die in een bepaalde map in Outlook staan weg te schrijven in een excel bestand. Echter zou ik willen dat hij pas begint met wegschrijven van de emails in row 3 bijvoorbeeld. Dit is de geheelde macro code:


Sub ExportToExcel()

On Error GoTo ErrHandler

Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object

strSheet = "macro.xls"
strPath = "G:\Tilburg\Public\Orderwijzingen macro\"
strSheet = strPath & strSheet
Debug.Print strSheet

'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder

'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
End If

'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True

'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1 <<<Hier zit denk ik de fout
Set msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.To
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SenderEmailAddress
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.ReceivedTime
Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing

Exit Sub

ErrHandler:
If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, _
"Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, _
"Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing

End Sub


Dus ik wil in het rode gedeelde de code weten waarmee ik aangeef in welke Row hij de data van de emails begint weg te schrijven.

Alvast bedankt!

 

[AlexV]

Hoi Marc,

Je praat over Row maar je wil de Column aangeven waar je begint?
Als je wil dat de code begint te schrijven op row 3 dan nog even aangeven dat die op drie moet beginnen.

'Copy field items in mail folder.
[COLOR="Lime"]intRowCounter = 2[/COLOR]
For Each itm In fld.Items
intColumnCounter = 1 <<<Hier zit denk ik de fout
Set msg = itm

Ik denk dat ik je vraag niet goed begrijp want je zou dit toch weten als ik je code bekijk.


Gr,
Alex,

 

[marcfields]

Hoi Alex, bedankt voor je snelle reactie.

Nee ik wil inderdaad dat de code begint te schrijven op Row 3. Met de roodgemarkeerde tekst doelde ik alleen dat ik gokte dat de code daar ergens moet tussen staan.

Met de regel: intRowCounter = 2 begint ie inderdaad te schrijven op regel 3, nu is het alleen zo dat ie dan niet alle berichten weg schrijft. Dan slaat ie bijvoorbeeld de eerste 2 email berichten over (die achter Row 1 en 2 zitten) en begint ie pas met wegschrijven bij het 3e emailbericht. Dus dan mis ik twee e-mail berichten, erg vaag!

Heb jij een oplossing hiervoor?

BVD!

 

[AlexV]

Jazeker dan kun je ook de 2 mee geven met je Set

Set rng = wks.Cells(intRowCounter + 2, intColumnCounter)

Zou zelf de het volgende doen ipv Set

wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.To
    intColumnCounter = intColumnCounter + 1
wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.SenderEmailAddress
    intColumnCounter = intColumnCounter + 1
wks.Cells(intRowCounter, intColumnCounter).Value = msg.Subject
    intColumnCounter = intColumnCounter + 1
wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.SentOn
    intColumnCounter = intColumnCounter + 1
wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.ReceivedTime

Gr,
Alex,

 

[marcfields]

Alex!!

Bedankt! Sorry voor late reactie, had weinig tijd dit weekend. Vanochtend geprobeerd op mijn werk en de macro werkt nu perfect, echt super! Gaat me heel veel tijd besparen!

Nogmaals bedankt!

Gr.
Marc

 

[marcfields]

Hoi allen,

ik ben tegen een nieuw probleem aangelopen. Ik wil nu nog meer data van de email wegschrijven naar excel met de vba code. De data die tot nu toe wordt weggeschreven wordt in de code als volgt genoteerd:

For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter + 2, intColumnCounter)
wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.Subject
intColumnCounter = intColumnCounter + 1
wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.To
intColumnCounter = intColumnCounter + 1
wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.SenderEmailAddress
intColumnCounter = intColumnCounter + 1
wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.ReceivedTime

Nu wil ik echter nog een ander gegeven uit de email wegschrijven in excel. Ik heb namelijk een e-mail form opgesteld waarin ik ook ordernummers kan invoeren. Dat standaard field wordt in de form 'ordernummer' genoemd. Nu wil ik dus ook het field 'ordernummer' wegschrijven. Ik kwam zelf met het idee om in de VBA code simpel tussen bovengenoemde code dit te plakken:

wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.Ordernummer
intColumnCounter = intColumnCounter + 1

Dit werkte echter niet. Mijn vraag dus nu, hoe kom ik achter de benaming in VBA voor mijn eigen gemaakte form fields? Misschien een wat onduidelijk verhaal, maar mocht je vragen hebben dan probeer ik zo duidelijk mogelijk te reageren

alvast bedankt

 

[AlexV]

Hoi Marc,

Als je de 'TextBox' in je form selecteert en je 'Properties Window' open hebt.
Zie je de naam van je object vermoedelijk Textbox1 voor de eerste die je er in gezet hebt.
Nu zul je ook nog de naam van de userform er voor zetten.
Dus

UserForm1.TextBox1.Value

hoop dat je hier verder mee komt.

Gr,
Alex,

 

[snb]

Sjonge.....
Dat kan simpeler:

Sub ExportToExcel()
 for each it in Application.GetNamespace("MAPI").PickFolder.items
    c2=c2 & vbcr & it.To & "|" &  it.SenderEmailAddress & "|" & it.Subject & "|" & it.SentOn & "|" & it.ReceivedTime
  Next 
  with getobject("G:\Tilburg\Public\Orderwijzingen macro\")
    .sheets(1).cells(3,1).resize(ubound(split(c2,vbcr)))=.application.transpose(split(c2,vbcr))
    .sheets(1).columns(1).texttocolumns , 1, -4142, , False, False, False, False, True, "|"
  End With
End Sub

 

[marcfields]

@snb, dankje voor je reactie. Ik weet alleen niet goed wat ik dan precies moet vervangen/verplaatsen.En ben namelijk niet zo goed met VBA, en dadelijk verpruts ik de rest van mijn code. Dus dat kan ik denk ik beter niet doen.

@Alex: oke dus als ik de form aan het maken ben moet ik de desbetreffende textboxen selecteren en vervoglens via 'advanced properties' de name veranderen in 'Username1.Textbox1.Value'.

Wordt dan de code dus ook in VBA:

wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.Userform1.Textbox1.Value
intColumnCounter = intColumnCounter + 1

of zit ik er nu helemaal naast?
Bedankt voor jullie hulp

 

[snb]

Mijn code doet hetzelfde als de jouwe. Test maar.

 

[marcfields]

@snb bedoel je dat je jou code van een paar regels helemaal kan vervangen voor mijn stuk langere code???

zo ja, dan werkt ie niet. Want dan krijg ik de volgende foutmelding:

http://img227.imageshack.us/img227/2489/screenshotttt.png

 

[snb]

Had je zelf ook kunnen zien:

Sub ExportToExcel()
 for each it in Application.GetNamespace("MAPI").PickFolder.items
    c2=c2 & vbcr & it.To & "|" &  it.SenderEmailAddress & "|" & it.Subject & "|" & it.SentOn & "|" & it.ReceivedTime
  Next 
  with getobject("G:\Tilburg\Public\Orderwijzingen macro\[COLOR="Red"]macro.xls"[/COLOR])
    .sheets(1).cells(3,1).resize(ubound(split(c2,vbcr)))=.application.transpose(split(c2,vbcr))
    .sheets(1).columns(1).texttocolumns , 1, -4142, , False, False, False, False, True, "|"
  End With
End Sub

PS. Ik ga ervan uit dat je deze macro in Outlook draait.
PPS. controleer of het bestand waarnaar verwezen wordt bestaat.
PPPS en als het om Postvak IN gaat zou ik het zo doen:

Sub ExportToExcel()
 for each it in Application.GetNamespace("MAPI").[COLOR="Red"]GetDefaultFolder(6).[/COLOR]items
    c2=c2 & vbcr & it.To & "|" &  it.SenderEmailAddress & "|" & it.Subject & "|" & it.SentOn & "|" & it.ReceivedTime
  Next 
  with getobject("G:\Tilburg\Public\Orderwijzingen macro\[COLOR="Red"]macro.xls"[/COLOR])
    .sheets(1).cells(3,1).resize(ubound(split(c2,vbcr)))=.application.transpose(split(c2,vbcr))
    .sheets(1).columns(1).texttocolumns , 1, -4142, , False, False, False, False, True, "|"
  End With
End Sub

PS$. En verwijder overal 'Option Explicit'.

 

[marcfields]

PS: Ja gebruik outlook
PPS : Ja daar was ik net zelf al achter dat de folder niet goed was, nu de folder wel goed krijgik de volgende melding:

Microsoft Excel
! "Do you want to replace the contents of the destination cells."3

Als ik op Ok druk gebeurt er niets.... excel wordt niet geopend en het bestnd is ook niet gewijzigd. Als ik op annuleren druk krijg ik een nieuwe foutmelding in VBA die naar de regel in het rood verwijst.

Sub ExportToExcel()
 For Each it In Application.GetNamespace("MAPI").PickFolder.Items
    c2 = c2 & vbCr & it.To & "|" & it.SenderEmailAddress & "|" & it.Subject & "|" & it.SentOn & "|" & it.ReceivedTime
  Next
  With GetObject("G:\Tilburg\Public\Orderwijzingen\Codes\macro.xls")
    .Sheets(1).Cells(3, 1).Resize(UBound(Split(c2, vbCr))) = .Application.Transpose(Split(c2, vbCr))
   .[COLOR="red"]Sheets(1).Columns(1).TextToColumns , 1, -4142, , False, False, False, False, True, "|"[/COLOR]
  End With
End Sub

sorry misschien voor alle (domme) vragen, maar daarom zei ik al eerder dat ik niet zo goed was met VBA

PPPS: nee ik wil zelf de folder selecteren dus houdt hem liever op 'pickfolder'
PS$: wat bedoel je met verwijder over 'option explicit

 

[snb]

Sub ExportToExcel()
 For Each it In Application.GetNamespace("MAPI").PickFolder.Items
    c2 = c2 & vbCr & it.To & "|" & it.SenderEmailAddress & "|" & it.Subject & "|" & it.SentOn & "|" & it.ReceivedTime
  Next
  With GetObject("G:\Tilburg\Public\Orderwijzingen\Codes\macro.xls")
    .application.displayAlerts=False
    .Sheets(1).Cells(3, 1).Resize(UBound(Split(c2, vbCr))) = .Application.Transpose(Split(c2, vbCr))
   .Sheets(1).Columns(1).TextToColumns , 1, -4142, , False, False, False, False, True, "|"
   .Save
   .application.visible=true
  End With

End Sub

 

[marcfields]

snb, wow je bent echt heel slim dat je zo simpel de fout vermeldingen oplost.

nu treed er echter een nieuw problemen op. VBA geeft geen foutmeldingen meer, en zoals het eruit ziet voert ie ook echt de macro uit. Echter wordt excel niet automatisch geopend, en kan ik de weggeschreven data nergens terug vinden. Ook niet als ik het bestand waarna ik verwijs in de VBA zelf open in de desbetreffende map, nog erger zelfs: de standaart layout van 'macro.xls' is gewist en de excel sheet bestaat niet eens meer! Alleen een lege worksheet dus!

 

[snb]

NB. Het was geen foutmelding, maar een gebruikersmelding.

Sub ExportToExcel()
 For Each it In Application.GetNamespace("MAPI").PickFolder.Items
    c2 = c2 & vbCr & it.To & "|" & it.SenderEmailAddress & "|" & it.Subject & "|" & it.SentOn & "|" & it.ReceivedTime
  Next
  With GetObject("G:\Tilburg\Public\Orderwijzingen\Codes\macro.xls")
    .application.displayAlerts=False
    .Sheets(1).Cells(3, 1).Resize(UBound(Split(c2, vbCr))) = .Application.Transpose(Split(c2, vbCr))
   .Sheets(1).Columns(1).TextToColumns , 1, -4142, , False, False, False, False, True, "|"
   .Save
   .application.visible=true
 [COLOR="Blue"]  .Windows("macro.xls").Visible = True[/COLOR]
  End With
End Sub

 

[marcfields]

oke snb, code werkt. Maar met jou code verlies ik wel de standaard layout die ik had in het macro.xls bestand. Hij creëert dan echt een nieuwe workbook. Daar heeft die andere code wel voordeel bij.

nu echter, is mijn eerste vraag nog steeds niet beantwoord

Nu wil ik echter nog een ander gegeven uit de email wegschrijven in excel. Ik heb namelijk een e-mail form opgesteld waarin ik ook ordernummers kan invoeren. Dat standaard field wordt in de form 'ordernummer' genoemd. Nu wil ik dus ook het field 'ordernummer' wegschrijven.Mijn vraag dus nu, hoe kom ik achter de benaming in VBA voor mijn eigen gemaakte form fields? Misschien een wat onduidelijk verhaal, maar mocht je vragen hebben dan probeer ik zo duidelijk mogelijk te reageren

hopelijk kan alex nog reageren op reactie #9

 

[snb]

Maar met jouw code verlies ik wel de standaard layout die ik had in het macro.xls bestand. Hij creëert dan echt een nieuw workbook.

Dat kan niet kloppen. Getobject doet hetzelfde als Workbooks.open.
Ik weet niet wat jij dan met layout bedoelt.
Controleer eerst of het bestand wel de layout bevat die jij verwacht.

De andere vraag:

For Each it In Application.GetNamespace("MAPI").PickFolder.Items
    c2 = c2 & vbCr & it.To & "|" & it.SenderEmailAddress & "|" & it.Subject & "|" & it.SentOn & "|" & it.ReceivedTime & "|" & [COLOR="Red"]it.Userproperties("ordernummer")[/COLOR]
  Next

 

[marcfields]

Ah! snb bedankt, die had ik nodig!

Ik gebruik nu toch die oude code omdat ik dan mijn 'layout' goed blijft, moeilijk om uit te leggen maar het klopt in ieder geval. het stukje code waarin de vba moet verwijzen ziet er nu als volgt uit

For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter + 2, intColumnCounter)
wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.Subject
intColumnCounter = intColumnCounter + 1
[COLOR="Red"]wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.UserProperties("Ordernummer")
intColumnCounter = intColumnCounter + 1[/COLOR]
wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.To
intColumnCounter = intColumnCounter + 1
wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.SenderEmailAddress
intColumnCounter = intColumnCounter + 1
wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
wks.Cells(intRowCounter + 2, intColumnCounter).Value = msg.ReceivedTime

het werkt nu iig. bedankt allemaal voor de hulp