Po instalaci WIN 10 přestalo fungovat VBA Vyřešeno

Programy pro práci v kanceláři (Word, Excel, Access…=>Office)

Moderátor: Mods_senior

luko02420
Level 2
Level 2
Příspěvky: 165
Registrován: únor 12
Pohlaví: Nespecifikováno

Po instalaci WIN 10 přestalo fungovat VBA  Vyřešeno

Příspěvekod luko02420 » 03 bře 2020 06:36

Dobrý den, po upgrade z WIN 7 na WIN 10 mi přestalo fungovat odesílání emailu pomocí VBA. Nainstalovány WIN 10 Pro, office mám 2010. Na jiném pc s WIN 10 mi to jede bez problémů.
Nevíte někdo co s tím.
Děkuji za každou pomoc. Přikládám kód i screen.

Kód: Vybrat vše

Sub ExcelOutlookPriloha()
Dim objNsp As Object, colSyc As Object, objSyc As Object, i As Integer, adresat As String, Soubor As String, SouborXLSM As String, Cely As Boolean, O As Object, Pripona As String
    '!!!!!Před použitím je třeba v Tools / References zaškrtnout volbu Microsoft Outlook xx.0 Object Library.!!!!!
    'Tools / References / Microsoft Outlook x.x Object Library
   
    'Celý zošit = True, iba aktívny list = False
    Cely = False
   
    Sheets("Odesílání").Select
   
    With ActiveSheet
        With .Range("A1")
            .Value = Now()
            .NumberFormat = "d/m/yy h:mm;@"
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
        '.Range("D37:D38").ClearContents
   
        ' Uložení souboru
        Pripona = .Range("M1")
        Soubor = "\" & .Range("K1") & " " & .Range("L1") & "." & Pripona
       
        Select Case Pripona
            Case "xlsx", "xlsm": SouborXLSM = Replace(Soubor, ".xlsx", ".xlsm")
                         With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With
                         Select Case Cely
                            Case True:  ThisWorkbook.SaveCopyAs SouborXLSM
                                        If Pripona = "xlsx" Then
                                            With Workbooks.Open(SouborXLSM)
                                                .SaveAs Soubor, 51
                                                .Close
                                            End With
                                            Kill SouborXLSM
                                        End If
                            Case False: ActiveSheet.Copy
                                        With ActiveWorkbook
                                            If Pripona = "xlsx" Then .SaveAs Soubor, 51 Else .SaveAs SouborXLSM, 52
                                            .Close
                                        End With
                         End Select
                         With Application: .ScreenUpdating = True: .DisplayAlerts = False: End With
           
            Case "pdf": If Cely Then Set O = ThisWorkbook Else Set O = ActiveSheet
                        O.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Soubor, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        End Select
       
    End With
   
    Sheets("ssss ").Select
   
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    Set objNsp = OutApp.Application.GetNamespace("MAPI")  'CORRECTION to Refer to the OutLook Application correctly
    Set colSyc = objNsp.SyncObjects
   
    adresat = "sss@sss.com"
   
    With OutMail
        'adresát
        .To = adresat
        'předmět zprávy
        .Subject = "ssss"
       
        'aktivní (uložený) sešit jako příloha
        .Attachments.Add Soubor
       
        'Nastavení preferovaného účtu pro odeslání pošty - v tomto případě druhý v pořadí
        'Dostupné od verze Office 2007
        .SendUsingAccount = OutApp.Session.Accounts.Item(1)
        'odeslání zprávy
        .Send
       
    End With
   
    For i = 1 To colSyc.Count
        Set objSyc = colSyc.Item(i)
        objSyc.Start
    Next i
     'Kill Soubor
    'OutApp.Quit
    MsgBox "Zpráva byla odeslána na adresu: " & ".", vbInformation  'adresat
    'uvolnění z paměti
    Set OutMail = Nothing: Set objNsp = Nothing: Set colSyc = Nothing: Set objSyc = Nothing: Set OutApp = Nothing: Set O = Nothing
End Sub


1671

Dodatečně přidáno po 2 hodinách 53 minutách 39 vteřinách:
Tak jsem teď zjistil, že je to zaviněno Officem 2010. Nějak nespolupracuje s WIN 10. Takže téma uzavírám



Reklama
  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek
  • WI-FI přestala fungovat
    od Shadehazard » 28 lis 2019 17:15 » v Sítě - hardware
    9
    596
    od ITCrowd
    28 lis 2019 19:44
  • Bude to fungovat ?
    od viyrag » 12 dub 2020 16:27 » v Rady s výběrem hardwaru a sestavením PC
    4
    253
    od petr22
    12 dub 2020 16:43
  • sestava - bude vše fungovat?
    od vasson » 08 dub 2020 14:17 » v Rady s výběrem hardwaru a sestavením PC
    1
    203
    od xbs
    08 dub 2020 15:12
  • Bude mi fungovat tento monitor?
    od Angelo » 01 lis 2019 11:17 » v Rady s výběrem hardwaru a sestavením PC
    5
    414
    od Angelo
    01 lis 2019 12:35
  • Kontrola PC Sestavy, bude takto fungovat ?
    od Vojta6 » 13 kvě 2020 16:09 » v Rady s výběrem hardwaru a sestavením PC
    5
    264
    od xbs
    14 kvě 2020 04:53

Zpět na “Kancelářské balíky”

Kdo je online

Uživatelé prohlížející si toto fórum: Brandwatch [Bot], CommonCrawl [Bot], elninoslov a 2 hosti