Werkblad verzenden per email

[J.Harsveld]

Beste Exceltechneuten,

Deze vraag heb ik al eerder gesteld, zie ook berichtgeving op data 26-5-08
9:02 en om 21:52 uur
Ik heb een excel 2000 bestandje met div. werkbladen en ik zoek naar een
mogelijkheid dat er slechts 1 werkblad per email verzonden kan worden en de
overige bladen niet. Dit mag een stukje VBA zijn onder een actieve macro of
als het niet anders kan dan onder een macroknop.
Ik had al eerder een VBA code toegezonden gekregen, zie onderaan bericht
maar werkte niet goed of ik heb niet juist gehandeld. Dit leverde alleen
maar problemen voor mij op.

Vandaar een tweede poging voor hetgene wat ik zoek.

Bij voorbaat dank

m. vr. gr.
Jahar

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim cmbCtr As CommandBarControl
Dim blnSheet As Boolean
blnSheet = (StrComp(Sh.Name, "Blad1", vbTextCompare) = 0)
Application.CommandBars("Envelope").Enabled = blnSheet
For Each cmbCtr In Application.CommandBars("Standard").Controls
If cmbCtr.ID = 3738 Then
cmbCtr.Enabled = blnSheet
Exit For
End If
Next
End Sub

[Ron de Bruin]

Zie deze pagina voor code voorbeelden of install de add-in
http://www.rondebruin.nl/sendmail.htm

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

"J.Harsveld" <hrs...@wanadoo.nl> wrote in message news:483c44b3$0$29441$dbd4...@news.wanadoo.nl...

[jan]

Jahar,

Misschien kun je aangeven waarom onderstaande code niet werkt, of wat er mis was.
En wat is precies de bedoeling van de code die wenst. Misschien staat er zoiets wel
op de site van Ron.

Jan

"J.Harsveld" <hrs...@wanadoo.nl> schreef in bericht
news:483c44b3$0$29441$dbd4...@news.wanadoo.nl...

[Ron de Bruin]

Denk dat ik zou kiezen voor dit in de Thisworkbook module Jan

Private Sub Workbook_Activate()
For Each Ctrl In Application.CommandBars.FindControls(ID:=3738)
Ctrl.Enabled = False
Next Ctrl
End Sub

Private Sub Workbook_Deactivate()
For Each Ctrl In Application.CommandBars.FindControls(ID:=3738)
Ctrl.Enabled = True
Next Ctrl
End Sub

En dan een macro knop op de sheet die je wil om te mailen

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

"jan" <j...@releerf.nl> wrote in message news:OkFU7hC...@TK2MSFTNGP06.phx.gbl...

[Ron de Bruin]

Even nog een dim regel erbij zetten in beide events

Dim Ctrl As Office.CommandBarControl

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

"Ron de Bruin" <ronde...@kabelfoon.nl> wrote in message news:u9JbSzCw...@TK2MSFTNGP03.phx.gbl...

[jan]

Ron,

Het was inderdaad al wel duidelijk dat er iets mis ging bij het gaan naar andere
werkmappen en bij het sluiten van de werkmap.
Ik was ondertussen zover gekomen:

Private Sub Workbook_Activate()
Dim blnSheet As Boolean
blnSheet = (StrComp(ActiveSheet.Name, "Blad1", vbTextCompare) = 0)
Reset blnSheet
End Sub

Private Sub Workbook_Deactivate()
Reset True
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

Dim blnSheet As Boolean
blnSheet = (StrComp(Sh.Name, "Blad1", vbTextCompare) = 0)

Reset blnSheet
End Sub

Sub Reset(blnSheet As Boolean)
Dim cmbCtr As CommandBarControl

For Each cmbCtr In Application.CommandBars("Standard").Controls
If cmbCtr.ID = 3738 Then
cmbCtr.Enabled = blnSheet
Exit For
End If
Next
Application.CommandBars("Envelope").Enabled = blnSheet

End Sub

Maar ik vind jouw gebruik van FindControls een stuk eleganter en die vindt bovendien
eventueel meerdere aanwezige knoppen met ID=3738
Deze code zou ik alsvolgt willen verwerken in Sub Reset:

Sub Reset(blnSheet As Boolean)
Dim cmbCtr As CommandBarControl
For Each cmbCtr In Application.CommandBars.FindControls(ID:=3738)
cmbCtr.Enabled = blnSheet
Next

Application.CommandBars("Envelope").Enabled = blnSheet

End Sub

Er wordt in bovenstaande van uitgegaan dat het blad met de naam "Blad1" verzonden
moet kunnen worden en alle andere werkbladen niet..
Ook daar ligt denk ik een probleempje bij de eerste poging van Jahar.
Jammer dat hij een nieuwe installatie van Excel heeft gedaan, dat was denk ik niet
nodig geweest.

Jan

"Ron de Bruin" <ronde...@kabelfoon.nl> schreef in bericht
news:u9JbSzCw...@TK2MSFTNGP03.phx.gbl...

[J.Harsveld]

Beste Jan,

Op de jou vba code liep ik steeds vast omdat na de eerste keer wel op juiste
wijze werkte maar bij afsluiten en weer opstarten van van het bestandje gaat
het mis. Dan zijn alle werkbladen verzendbaar via het icoontje in het
menubalk en dat was bedoeling. Ik toen alles verwijderd inclusief het
officepakket omdat het icoontje niet meer aanspreekbaar kon krijgen en ook
even niet wist hoe dat weer te corrigeren was en met hulp vanuit deze is dat
gelukt.

Op site van Ron de Bruin heb ik ook gekeken maar gezien mijn zeer gebrekige
engels zal het stoeien worden om daar uit te komen.

m.vr.gr.
Jahar

"jan" <j...@releerf.nl> schreef in bericht
news:OkFU7hC...@TK2MSFTNGP06.phx.gbl...

[Ron de Bruin]

> Jammer dat hij een nieuwe installatie van Excel heeft gedaan, dat was denk ik niet
> nodig geweest.

Simpel je Excel<versienummer>.xlb bestand een andere naam geven zal alle menu's weer herstellen.

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

"jan" <j...@releerf.nl> wrote in message news:eS%23Nf$CwIHA...@TK2MSFTNGP02.phx.gbl...

[Ron de Bruin]

Hallo Jahar

Bedenk wel dat alle code niet werkt als een gebruiker macros niet
inschakeld of de beveiling op hoog heeft staan.

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

"J.Harsveld" <hrs...@wanadoo.nl> wrote in message news:483c65de$0$53214$dbd4...@news.wanadoo.nl...

[J.Harsveld]

Beste Ron,

De macrobeveiliging staat op de juiste wijze ingeschakelt (gemiddeld) daar
het prog al een tal van macro kent.
En in een toelichting die in het prog. zit wordt er aan derden nog op eens
gewezen.

Maar in de discussie tussen jou en Jan zie ik tussen de bomen het bos niet
meer. M.a.w. Hoe moet ik nou handelen en wat nou wel en niet correct??????

"Ron de Bruin" <ronde...@kabelfoon.nl> schreef in bericht

news:uE8dNSDw...@TK2MSFTNGP04.phx.gbl...

[jan]

Ron,

Zelfs dat was niet nodig, alleen dat ene icoontje was onbereikbaar geworden.
Met deze regels was dat opgelost geweest:

Sub Reset(blnSheet As Boolean)
Dim cmbCtr As CommandBarControl
For Each cmbCtr In Application.CommandBars.FindControls(ID:=3738)

cmbCtr.Enabled = True
Next
Application.CommandBars("Envelope").Enabled = True
End Sub

Jan

"Ron de Bruin" <ronde...@kabelfoon.nl> schreef in bericht

news:uRZzuLDw...@TK2MSFTNGP03.phx.gbl...

[jan]

Jahar,

Neem deze code op in je werkboek module:

Private Sub Workbook_Activate()
Dim blnSheet As Boolean

blnSheet = (StrComp(ActiveSheet.Name, "Blad1", vbTextCompare) = 0)
Reset blnSheet
End Sub

Private Sub Workbook_Deactivate()
Reset True
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

Dim blnSheet As Boolean
blnSheet = (StrComp(Sh.Name, "Blad1", vbTextCompare) = 0)

Reset blnSheet
End Sub

Sub Reset(blnSheet As Boolean)
Dim cmbCtr As CommandBarControl

For Each cmbCtr In Application.CommandBars.FindControls(ID:=3738)
cmbCtr.Enabled = blnSheet
Next

Application.CommandBars("Envelope").Enabled = blnSheet

End Sub

Vervang in bovenstaande desnoods "Blad1" door de naam van het werkblad dat moet
kunnen worden verzonden.
Dan moet het m.i. werken zoals je wenst.

Gaat er dan iets niet zoals je had verwacht, reageer dan even in deze discussie,
zodat een remedie aangedragen kan worden die waarschijnlijk minder ingrijpend is dan
een hele nieuwe installatie van Office.

Jan

[J.Harsveld]

Beste Jan,

Ik heb het onderstaande VBA code even uitgeprobeerd in een proefmaje en dat
lijkt geheel naar wens te werken. Ik ga het z.s.m. verder uitwerken in mijn
prog. en laat de afloop ervan even weten maar dat kan een paar dagen duren.

m.vr.gr.
Jahar

"jan" <j...@releerf.nl> schreef in bericht

news:OqaEIxDw...@TK2MSFTNGP02.phx.gbl...

[jan]

Jahar,

Om het iets netter te houden: vervang in de code overal Reset even door iets als
envReset.
Het woord Reset wordt namelijk ook als methode gebruikt binnen VBA en dan is het
beter om dat woord niet voor een eigen procedure o.i.d. te gebruiken.

Jan

"J.Harsveld" <hrs...@wanadoo.nl> schreef in bericht

news:483c7be7$0$29181$dbd4...@news.wanadoo.nl...

[J.Harsveld]

Beste Jan,

Met jou VBA code gestoeid te hebben ben ik er maar gedeeltelijk uitgekomen.
Opzich werkte jou VBA code wel maar en dit realiseerde ik mij pas achteraf
dat de ontvanger met het bericht er weinig kan doen voor verdere verwerking,
bijv. plaatsing op een website.
Op de site van Ron de Bruin had ik ook iets gevonden en uitgeprobeerd.
Daarmee kon je het werkblad als bijlage versturen. Opzich werkte ook goed
maar daar dook het probleem op dat de ontvanger bij het openen van de
bijlage een hoop nullen ziet en dat komt weer door het feit dat het formules
uit het prog. zijn.

Dus ik weet het even niet meer.

m.vr.gr.
Jahar

[J.Harsveld]

[Jan B.]

J.H.

ik heb daar ook lang mee gestoeid met uiteindelijk goed resultaat. uiteraard
met de routine van Ron de bruin erin en nog wat uitbreidingen.
Om fouten te voorkomen: maak in de map waar je het prgramma zet ook een map
met de naam "Archief.

Stuur me je e-mailadres en dan stuur ik je een een goedwerkend bestand.
Voor de vollegheid stuur ik je hierbij de volledige code:

Private Sub Workbook_Open()
On Error Resume Next
Call toolbar
On Error GoTo 0
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.CommandBars("MyToolbar").Delete
On Error GoTo 0
End Sub

Sub toolbar()
Dim NewBtn As CommandBarControl
Dim TBar As CommandBar
Application.ScreenUpdating = False

' Create the toolbar
On Error Resume Next
CommandBars("MyToolbar").Delete
On Error GoTo 0
Set TBar = CommandBars.Add
With TBar
.Name = "MyToolbar"
.Position = msoBarTop
.Protection = msoBarNoMove + msoBarNoCustomize + msoBarNoChangeVisible
.Left = 1
.Visible = True
End With

' Opslaan
Set NewBtn = CommandBars("MyToolbar").Controls.Add(Type:=msoControlButton)
With NewBtn
.BeginGroup = True
.Style = msoButtonIcon
.FaceId = 3
.OnAction = "opslaan"
.Caption = " Opslaan "
.Height = 32
.Width = 64
End With

' Archiveren (Icon)
Set NewBtn = CommandBars("MyToolbar").Controls.Add(Type:=msoControlButton)
With NewBtn
.BeginGroup = True
.Style = msoButtonIcon
.FaceId = 32
.OnAction = "werkblad_save"
.Caption = " Dít blad archiveren "
.Width = 32
End With

' Mail (Icon)
Set NewBtn = CommandBars("MyToolbar").Controls.Add(Type:=msoControlButton)
With NewBtn
.Style = msoButtonIcon
.FaceId = 777
.OnAction = "werkblad_mail"
.Caption = " Dít blad mailen "
.Width = 32
End With

' Print (Icon)
Set NewBtn = CommandBars("MyToolbar").Controls.Add(Type:=msoControlButton)
With NewBtn
.Style = msoButtonIcon
.FaceId = 4
.OnAction = "werkblad_print"
.Caption = " Dít blad afdrukken "
.Width = 32
End With

' Afdrukvoorbeeld (Icon)
Set NewBtn = CommandBars("MyToolbar").Controls.Add(Type:=msoControlButton)
With NewBtn
.Style = msoButtonIcon
.FaceId = 109
.OnAction = "werkblad_preview"
.Caption = " afdrukvoorbeeld "
.Width = 32
End With

End Sub

Public filenaam$, wisrij$, wiskol$, blad

Sub opslaan()
ActiveSheet.Protect
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.DisplayAlerts = True
End Sub

Sub werkblad_gegevens()
Application.ScreenUpdating = False

' init
emailadres = "": bodytekst = ""

' werkbladen voor eigen gebruik
tekst = ActiveSheet.Name
wisrij = ""
wiskol = ""
shapes = False
RH = tekst & " " & Year(Now())
gebied = "x" 'of anders Selection.Address

' printerinstelling
With ActiveSheet.PageSetup
Application.DisplayAlerts = False
If gebied <> "x" Then .PrintArea = gebied
Application.DisplayAlerts = True
If ActiveSheet.Name <> "factuur" Then
.LeftHeader = "&""Arial,Vet""&11tekst links"
.CenterHeader = ""
.RightHeader = "&""Arial,Vet""&11" & RH
.LeftFooter = "&8&D &T"
.CenterFooter = "&8&P van &N"
.RightFooter = "&8&F"
End If
End With

' bepaal filenaam
filenaam = ThisWorkbook.Path & "\Archief\" & tekst & "_" & Date & ".xls"

Application.ScreenUpdating = True
End Sub

Sub werkblad_preview()
Call werkblad_gegevens
ActiveWindow.SelectedSheets.PrintPreview
End Sub

Sub werkblad_print()
Call werkblad_gegevens
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End Sub

Sub werkblad_save()

' maak afdrukbestand
Call werkblad_gegevens
Call werkblad_xls
[A1].Select
Application.ScreenUpdating = False

' opslaan
On Error GoTo myError
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=filenaam
ActiveWindow.Close

Application.DisplayAlerts = True
Application.ScreenUpdating = True
On Error GoTo 0
Exit Sub

myError:
If Sheets.Count = 1 Then ActiveWorkbook.Close
Application.ScreenUpdating = True
MsgBox (" Er is een fout opgetreden. Het blad is niét gearchiveerd. ")
Application.DisplayAlerts = True
On Error GoTo 0
End Sub

Sub werkblad_mail()
' De volgende verwijzingen (VBE > Extra > Verwijzingen) aanvinken:
' - VisualBasic for Applications
' - Microsoft Excel 11.0 Object Library
' - OLE Automation
' - Microsoft Office 11.0 Object Library
' - Microsoft Forms 11.0 Object Library

Application.ScreenUpdating = False

' maak attachment
Call werkblad_gegevens
Call werkblad_xls
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs filenaam

' Ron de Bruin
On Error GoTo MyExit
With ActiveWorkbook
Set outapp = CreateObject("Outlook.Application")
Set outmail = outapp.CreateItem(olMailitem)
With outmail
.To = emailadres
.Subject = onderwerp
.body = bodytekst
.Attachments.Add filenaam
.Display
End With
End With
Set outmail = Nothing
Set outapp = Nothing

' sluit en wis attachment
ActiveWorkbook.Close
Kill filenaam

Application.ScreenUpdating = True
Application.DisplayAlerts = True
On Error GoTo 0
emailadres = ""
Exit Sub

MyExit:
If Sheets.Count = 1 Then ActiveWorkbook.Close
Application.ScreenUpdating = True
MsgBox " Er is een fout opgetreden. Het email is niét verzonden! ",
vbExclamation
Application.DisplayAlerts = True
On Error GoTo 0
End Sub

Sub werkblad_xls()
Application.ScreenUpdating = False

' kopieer werkblad naar nieuwe sheet
ActiveSheet.Copy
ActiveSheet.Unprotect

' wis validatie(s)
Cells.Select
Selection.Validation.Delete

' vervang formules door waarden
Cells.Select
Selection.Copy
On Error Resume Next
Selection.PasteSpecial Paste:=xlPasteValues
On Error GoTo 0
[A1].Select

' wis overbodige rijen en kolommen (hier laten staan ivm index-formules
If wisrij <> "" Then Rows(wisrij).Delete Shift:=xlUp
If wiskol <> "" Then Range(wiskol).Delete Shift:=xlToLeft

' wis alle shapes
If shapes = True Then
ActiveSheet.shapes.SelectAll
Selection.Delete
End If

' opmaak
ActiveWindow.FreezePanes = False
ActiveWindow.DisplayHeadings = True
With Application
.GoTo [A1], scroll:=True
.CutCopyMode = False
End With
End Sub

--
met vriendelijke groet,
Jan B.

"J.Harsveld" schreef:

[J.Harsveld]

Beste Jan B.,

Ik heb jou VBA code even vluchtig bekeken en volgens mij beoogd jou code
veel meer opties dan wat ik zoek en nodigd heb.
Momenteel heb ik de routine "Mail one sheet" in gebruik maar daar tob ik
weer mee met ormules als ik dat eerder heb aangegeven.

m.vr.gr.
Jahar

"Jan B." <jbronzwaer(dit weglaten)@home.nl> schreef in bericht
news:42FD1C56-DA4B-44EB...@microsoft.com...

[Jan B.]

Als je een werkblad per e-mail verzendt móet je alle formules vervangen door
waarden, anders krijgt de onvanger problemen.
In mijn code (module werkblad_xls) staan regels die de formules vervangen
door waarden. Dat moet natuurlijk niet gebeuren in het origineel maar in de
kopie die in deze module wordt gemaakt. Als je mijn code in z'n geheel
gebruikt zul je zien dat dit uitstekend werkt. Sla de code maar eens op in de
vbe-editor van een leeg excelbestand. De eerste twee modules moeten
natuurlijk in ThisWorkbook staan. Je krijgt dan een menubalk met ikonen die
de volgende acties doen : archiveren, verzenden per e-mail,
printvoorbeeldbekijken en afdrukken. Lijken me onmisbare opties op een
gebruikersmenubalk.
Je zult zien dat dit perfect werkt, mits je Outlook deel uitmaakt van het
Officepakket. Met Outlook Express werkt het dus niet.
Maar voor die problematiek moet je zijn op de website van Ron de Bruin. Die
weet er alles van.

[J.Harsveld]

Oké Jan B,

Ik ga je VBA code eens in een proefmap uitproberen.
Alleen denk ik, zoals je al aangeeft dat ik in botsing komt met Outlook daar
ik Outlook Express gebruik en géén Outlook uit mijn Officepakket.

m.vr.gr.
Jahar

"Jan B." <jbronzwaer(dit weglaten)@home.nl> schreef in bericht

news:A51A6132-8887-45E9...@microsoft.com...

[Jan B.]

Goed idee JH,

gebruik je echter Outlook Express, gebruik dan de code van Ron de Bruin.,
die hij hiervoor op zijn site aanbiedt. Mijn ervaring is echter dat de
Office-versie van Outlook dit allemaal vele malen soepeler laat verlopen.
Als we die Ron de Bruin toch niet hadden . . . .

[Ron de Bruin]

Als je formulas wil veranderen in waarden en OE gebruikt test dan deze

http://www.rondebruin.nl/mail/folder1/mail2.htm

Haal de comma's voor dit blokje weg zodat het ook code is en geen text meer

' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

"J.Harsveld" <hrs...@wanadoo.nl> wrote in message news:483ec889$0$96286$dbd4...@news.wanadoo.nl...

[J.Harsveld]

Mijne heren,

Ik ben ermee gestopt want ik ben onderhand knettergek van geworden en het
wil maar niet lukken ondanks de aangedragen susgesties vanuit deze groep

m.vr.gr.
Jahar

"Ron de Bruin" <ronde...@kabelfoon.nl> schreef in bericht

news:uQlCt0cw...@TK2MSFTNGP04.phx.gbl...