Beim Mailversand alle Makros löschen

Sub Mail_senden() Application.ScreenUpdating = False Dim olAPP As Object Dim olMail As Object Set olAPP = CreateObject("Outlook.Application") Set olMail = olAPP.CreateItem(0) ActiveSheet.Copy ActiveWorkbook.SaveAs "C:\XXX\XXX\XXX\XXX\" & Sheets(1).Range("c1") & " " & Range("c6") & " " & _ Range("c14") & " " & Range("e8").Value & ".xls", FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False With olMail .to = "xxxxxxxxxxxxxxxxxx" .cc = "XXX@XXX.de; XXX@XXX.de" .Subject = Range("c6").Value & ":" .Body = "Hallo" & " " & Range("c6") & "," & Chr(13) & _ "" & Chr(13) & _ "anbei übersenden wir Ihnen zur Kenntnis und Bearbeitung, den nachstehenden Vorgang." & Chr(13) _ & _ "" & Chr(13) & _ "Für Rückfragen stehen wir selbstverständlich gern zur Verfügung." & Chr(13) & _ "" & Chr(13) & _ "Mit freundlichen Grüßen" & Chr(13) & _ Range("b2") & Chr(13) & _ .Attachments.Add ActiveWorkbook.FullName .Display End With ActiveWorkbook.Close Dim backupDir backupDir = "C:\XXX\XXX\XXX\XXX\" On Error Resume Next Shell "C:\XXX\XXX\XXX\XXX\*.*" Kill (backupDir & "\*.*") Set olAPP = Nothing Set olMail = Nothing Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Private Sub Workbook_Open() Dim i As Integer ReDim ControlTab1(7) With Tabelle1 Set ControlTab1(0).objCommand = .CommandButton1 Set ControlTab1(1).objCommand = .CommandButton2 Set ControlTab1(2).objCommand = .CommandButton3 Set ControlTab1(3).objCommand = .CommandButton4 Set ControlTab1(4).objOption = .OptionButton1 Set ControlTab1(5).objOption = .OptionButton2 Set ControlTab1(6).objOption = .OptionButton3 Set ControlTab1(7).objOption = .OptionButton4 End With End Sub

Private Sub objOption_Click() Select Case LCase(objOption.Name) Case "OptionButton1" Case "OptionButton2" Case "OptionButton3" ActiveSheet.Shapes("ComboBox2").OLEFormat.Object.Visible = False Case "OptionButton4" ActiveSheet.Shapes("ComboBox2").OLEFormat.Object.Visible = True End Select End Sub

Private Sub objOption_Click() Select Case LCase(objOption.Name) Case "optionbutton1" Case "optionbutton2" Case "optionbutton3" ActiveSheet.Shapes("ComboBox2").OLEFormat.Object.Visible = False Case "optionbutton4" ActiveSheet.Shapes("ComboBox2").OLEFormat.Object.Visible = True End Select End Sub

Sub Screen_Einfügen() Application.ScreenUpdating = False On Error GoTo Errorhandler Rows("15:23").Select Selection.RowHeight = 68 Range("A15").Select ActiveSheet.Paste On Error GoTo Errorhandler 1004 End Errorhandler: If Err = 1004 Then MsgBox ("Bitte erst Screenshot vom ISL mit ALT + Druck machen !") Exit Sub Resume Next Else Selection.ShapeRange.Height = 800 Selection.ShapeRange.Width = 1032 Selection.ShapeRange.Left = 10 Selection.ShapeRange.Top = 256 Selection.Name = "Bild1" Application.ScreenUpdating = True End If If Err = 1015 Then Exit Sub Resume Next Else Selection.ShapeRange.Height = 800 Selection.ShapeRange.Width = 1032 Selection.ShapeRange.Left = 10 Selection.ShapeRange.Top = 256 Selection.Name = "Bild1" End If Application.ScreenUpdating = True End Sub

Hallo,
Lege diesen in ein Normales Modul.
Aufrufen kannst Du den Code mit
Call Screen_Einfeugen_

Option Explicit
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
    ByRef PicDesc As PIC_DESC, _
    ByRef RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, _
    ByRef IPic As IPictureDisp) As Long
Private Declare Function CopyImage Lib "user32.dll" ( _
    ByVal handle As Long, _
    ByVal un1 As Long, _
    ByVal n1 As Long, _
    ByVal n2 As Long, _
    ByVal un2 As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
    ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
    ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" ( _
    ByVal wFormat As Integer) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type PIC_DESC
    lngSize As Long
    lngType As Long
    lnghPic As Long
    lnghPal As Long
End Type

Private Const PICTYPE_BITMAP = 1
Private Const CF_BITMAP = 2
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const GC_CLASSNAMEMSEXCEL = "XLMAIN"

Private Function Paste_Picture() As IPictureDisp
Dim lngReturn As Long, lngCopy As Long, lngPointer As Long
Dim i As Long
    If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
        lngReturn = OpenClipboard(FindWindow(GC_CLASSNAMEMSEXCEL, Application.Caption))
        If lngReturn > 0 Then
            lngPointer = GetClipboardData(CF_BITMAP)
            lngCopy = CopyImage(lngPointer, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            Call CloseClipboard
            If lngPointer <> 0 Then Set Paste_Picture = Create_Picture(lngCopy, 0&, CF_BITMAP)
        End If
    End If
    
End Function

Private Function Create_Picture( _
        ByVal lnghPic As Long, _
        ByVal lnghPal As Long, _
        ByVal lngPicType As Long) As IPictureDisp
    
Dim udtPicInfo As PIC_DESC, udtID_IDispatch As GUID
Dim objPicture As IPictureDisp
    
    With udtID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    
    With udtPicInfo
        .lngSize = Len(udtPicInfo)
        .lngType = PICTYPE_BITMAP
        .lnghPic = lnghPic
        .lnghPal = lnghPal
    End With
    
    Call OleCreatePictureIndirect(udtPicInfo, udtID_IDispatch, 0&, objPicture)
    
    Set Create_Picture = objPicture
    
End Function

'Prozedur zum Formatieren ******************************* 
Private Sub Formatiere_Picture(ByVal objPicture As Object)

With objPicture
    .ShapeRange.Height = 800
    .ShapeRange.Width = 1032
    .ShapeRange.Left = 10
    .ShapeRange.Top = 256
    .Name = "Bild1"
End With

End Sub

'Picture aus Zwischenablage in Tabelle ****************** 

Public Sub Screen_Einfeugen_()
Dim objPicture As IPictureDisp
Dim objShabe As Object


Call EmptyClipboard

Set objPicture = Paste_Picture

If Not objPicture Is Nothing Then
    ActiveSheet.Paste
    If TypeName(Selection) <> "Picture" Then
         Set objShabe = Nothing
    Else
         Set objShabe = Selection
    End If
End If

If Not objShabe Is Nothing Then
    Formatiere_Picture objShabe
Else
    MsgBox ("Bitte erst Screenshot vom ISL mit ALT + Druck machen !")
End If
    
End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

Beim Mailversand alle Makros löschen

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

161 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Beim Mailversand alle Makros löschen

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

161 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread