Sende email fra 1 side i et ark oprettet med mange sider

Er det stadig aktuelt? Hvis ja - send en mail til: pb@supertekst-it.dk - så returnere jeg en model.

Rem Kan tilpasses efter behov
Rem =========================
Const emneTekst = "Opgørelse"                      'Emne-tekst til mail
Const MailData = "MailData.xls"                    'temp. workbook til selektiv forsendelse - oprettes automatisk
Const arkNavn = "Ark1"                              ' Arknavn, der indeholder tabellerne
Const antalRækVogn = 38                            'pr. vogn
Const antalKolVogn = 5                              'pr. vogn
Rem =========================

Dim xsti
Dim ræk, hpArr(), antalSideskiftH, antalSideskiftV, rækNr
Dim indhRæk
Sub ForsendelseAfSider()
    findSti
    opsætningAfSider
End Sub
Private Sub findSti()
    xsti = ActiveWorkbook.Path
    If Right(xsti, 1) <> "\" Then
        xsti = xsti + "\"
    End If
End Sub
Private Sub opsætningAfSider()
Dim h, v, fraRække, tilRække, fraKolonne, tilKolonne, område, antalRækker, vognNr
    ActiveWorkbook.Sheets(arkNavn).Activate
   
    antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
    Cells(antalRækker, 1).Select
   
Rem Hent antallet af sideskift (vandrette)
    antalSideskiftH = Worksheets(arkNavn).HPageBreaks.Count
    antalSideskiftV = Worksheets(arkNavn).VPageBreaks.Count
   
    fraRække = 3
    tilRække = fraRække + antalRækVogn - 1
    fraKolonne = 1
    tilKolonne = fraKolonne + antalKolVogn - 1
    vognNr = 1
   
Rem Opsæt sideskift med 1. række pr.side
    For h = 1 To antalSideskiftH + 1
            For v = 1 To antalSideskiftV + 1
                område = konverter(fraKolonne) + CStr(fraRække) + ":" + konverter(tilKolonne) + CStr(tilRække)
               
                If Cells(fraRække, 1) <> "" Then
                    ActiveWorkbook.Sheets(arkNavn).Range(område).Select
                    Selection.Copy
                   
                    Workbooks.Add
                   
                    ActiveWorkbook.ActiveSheet.Paste
                    Application.CutCopyMode = False
                    ActiveSheet.Range("A1").Select
                           
                    ActiveWorkbook.SaveAs xsti + MailData
                    ActiveWindow.Close
                   
                    sendMail ActiveWorkbook.Sheets("mailadresser").Cells(vognNr, 1), emneTekst
                    vognNr = vognNr + 1
                   
                    Kill xsti + MailData
                Else
                    Stop
                End If
                fraKolonne = tilKolonne + 2
                tilKolonne = fraKolonne + antalKolVogn - 1
            Next v
           
            fraRække = tilRække + 2
            tilRække = fraRække + antalRækVogn - 1
            fraKolonne = 1
            tilKolonne = fraKolonne + antalKolVogn - 1
    Next h
   
    MsgBox ("Mail sendt til " + CStr(vognNr) + " vogne")
    End Sub
Private Function konverter(kol)
Dim cKol
    cKol = Chr(64 + kol)
   
    If cKol > "Z" Then
        cKol = "A" + Chr((65 + kol) - 27)
    End If
    konverter = cKol
End Function
Public Sub sendMail(modtager, emne)
Dim mailApp, Namespace, nyMail, att
        Set mailApp = CreateObject("Outlook.Application")
        Set Namespace = mailApp.GetNamespace("MAPI")
   
        Set nyMail = mailApp.CreateItem(olMailItem)
        Set nymod = nyMail.Recipients
        nymod.Add modtager
       
        Set att = nyMail.Attachments
        att.Add xsti + MailData
        nyMail.Subject = emne
   
        nyMail.Display                            'visning af mail
        nyMail.Send                                'send mailen
End Sub

Det virker bare

Jeg nåede ikke at skrive tak... så det er hermed gjort

mvh Johnny

Selv tak...

Hej Johnny

Besked via Eksperten - da mail til dig kommer retur....

Til det sidste - det lyder interessant..... - men under alle omstændigheder vil jeg gerne hjælpe dig - der er travlhed i mit firma p.t. - men dit problem kan nok "klemmes ind imellem" - så hvis du sender din fil....

Med venlig hilsen
Supertekst