Hot News:

Unser Angebot:

  Foren auf CAD.de (alle Foren)
  VBasic / vb.net / vbs / wsh
  Makro 32bit - 64bit

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
Autor Thema:   Makro 32bit - 64bit (211 mal gelesen)
xem
Mitglied
Zeichner


Sehen Sie sich das Profil von xem an!   Senden Sie eine Private Message an xem  Schreiben Sie einen Gästebucheintrag für xem

Beiträge: 832
Registriert: 07.08.2008

Software:
AutoCAD 2014 - 64bit
Windows 7 Pro - 64bit
PDFCreator 1.0.2 - 32bit
Ghostscript 9.0 - 64bit
PDF-XChange Viewer - 64bit
GIMP 2.6.8 - 64bit
MS Office 2010 - 32bit
Opera 12 - 32bit
MacroX - 32bit
7-zip - 64bit
-----------------------
Hardware:
Intel i5 680 3,6GHz @ 4GHz
8GB RAM 1333MHz
nVidia GTX 460 1024MB
Intel SSD 2.5 80GB X25-M
Samsung SyncMaster 245B+
Iiyama ProLite E1900s
Logitech mx518
Logitech G11
Roccat Sense Glacier Blue

erstellt am: 02. Okt. 2020 14:21    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Hallo,

wir speichern unsere E-Mails mit diesen Makro, was auch funktioniert.
Jetzt haben wir einen neuen PC bekommen mit Outlook 2019 und da funktioniert das Makro nicht.
Es öffnet sich kein Fenster um den Speicherort auszuwählen.

Woran kann das liegen?

Code:
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
            "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
    Private OFName As OPENFILENAME
    Private Type OPENFILENAME
        lStructSize As Long
        hwndOwner As LongPtr
        hInstance As LongPtr
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As LongPtr
        lpfnHook As LongPtr
        lpTemplateName As String
    End Type
 
#Else

    Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
            "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
    Private OFName As OPENFILENAME
    Private Type OPENFILENAME
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
    End Type
#End If


Private Const OFN_ALLOWMULTISELECT As Long = &H200
Private Const OFN_CREATEPROMPT As Long = &H2000
Private Const OFN_ENABLEHOOK As Long = &H20
Private Const OFN_ENABLETEMPLATE As Long = &H40
Private Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
Private Const OFN_EXPLORER As Long = &H80000
Private Const OFN_EXTENSIONDIFFERENT As Long = &H400
Private Const OFN_FILEMUSTEXIST As Long = &H1000
Private Const OFN_HIDEREADONLY As Long = &H4
Private Const OFN_LONGNAMES As Long = &H200000
Private Const OFN_NOCHANGEDIR As Long = &H8
Private Const OFN_NODEREFERENCELINKS As Long = &H100000
Private Const OFN_NOLONGNAMES As Long = &H40000
Private Const OFN_NONETWORKBUTTON As Long = &H20000
Private Const OFN_NOREADONLYRETURN As Long = &H8000&
Private Const OFN_NOTESTFILECREATE As Long = &H10000
Private Const OFN_NOVALIDATE As Long = &H100
Private Const OFN_OVERWRITEPROMPT As Long = &H2
Private Const OFN_PATHMUSTEXIST As Long = &H800
Private Const OFN_READONLY As Long = &H1
Private Const OFN_SHAREAWARE As Long = &H4000
Private Const OFN_SHAREFALLTHROUGH As Long = 2
Private Const OFN_SHAREWARN As Long = 0
Private Const OFN_SHARENOWARN As Long = 1
Private Const OFN_SHOWHELP As Long = &H10

Public Sub ListSaveAs()
' Definition der Variablen
Dim MyOlApp
Dim myInspector As Inspector
Dim MyItem As MailItem
Dim myNameSpace As NameSpace
Dim myfolder As MAPIFolder
Dim myOlSel As Outlook.Selection
Dim myOlExp As Outlook.Explorer
Dim MsgTxt As String
Dim strText As String
Dim strMail As MailItem
Dim antw, x As Integer
Dim tmp_FlagRequest
' Mail-Eingangsordner festlegen
Set myNameSpace = Outlook.GetNamespace("MAPI")
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)
' Markierter Eintrag
On Error Resume Next
' Ansicht auf Eingangsordner
'Set Application.ActiveExplorer.CurrentFolder = _
    myNameSpace.GetDefaultFolder (olFolderInbox)
Set myOlExp = Outlook.ActiveExplorer
' Markierte Mails zuweisen
Set myOlSel = myOlExp.Selection
' Alle markierten Mails durchlaufen
For x = 1 To myOlSel.Count
  Set MyItem = myOlSel.Item(x)
 
' Mail als erledigt kennzeichnen
  tmp_FlagRequest = MyItem.FlagStatus
  MyItem.FlagStatus = OlFlagStatus.olFlagComplete
  MyItem.Save
 
 
   
  If MyItem Is Nothing Then
    MsgBox "Nichts markiert"
  End If
  On Error GoTo 0
    ' Exportieren
    fkt_Export MyItem
  Next x
' Aufräumen
Set MyItem = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing
Set myfolder = Nothing
Set myNameSpace = Nothing
End Sub

Function fkt_Export(ByRef MyItem As MailItem)
Dim datum, Pfad, absender, Betreff, dateiname, antwort, Zeit, adresse, Text1, anvon
Dim myuser As Object
Dim ret As String
Dim antw As String
Dim sDate As Date
If MyItem Is Nothing Then Exit Function
datum = Format(MyItem.SentOn, "yyyymmdd")  ' Festlegung des Datumsformats für den Dateinamen
Zeit = Format(MyItem.SentOn, "hh'mm'ss")      ' Festlegung des Zeitformats für den Dateinamen

adresse = MyItem.To
absender = MyItem.SenderName
sDate = MyItem.ReceivedTime

adresse = Replace(adresse, Chr$(34), "")
adresse = Replace(adresse, ":", "_")
adresse = Replace(adresse, "<", "_")
adresse = Replace(adresse, ">", "_")
adresse = Replace(adresse, "?", "_")
adresse = Replace(adresse, "/", "_")
adresse = Replace(adresse, "\", "_")
adresse = Replace(adresse, "*", "_")
adresse = Replace(adresse, ".", ".")
adresse = Replace(adresse, "|", "-")
adresse = Replace(adresse, "[", "-")
adresse = Replace(adresse, "]", "-")
adresse = Replace(adresse, ";", "")
adresse = Replace(adresse, "'", "")


absender = Replace(absender, Chr$(34), "")
absender = Replace(absender, ":", "_")
absender = Replace(absender, "<", "_")
absender = Replace(absender, ">", "_")
absender = Replace(absender, "?", "_")
absender = Replace(absender, "/", "_")
absender = Replace(absender, "\", "_")
absender = Replace(absender, "*", "_")
absender = Replace(absender, ".", ".")
absender = Replace(absender, "|", "-")
absender = Replace(absender, "[", "-")
absender = Replace(absender, "]", "-")
absender = Replace(absender, ";", "")
absender = Replace(absender, "'", "")

Set myuser = Application.GetNamespace("MAPI").CurrentUser

If absender Like "*Schulze*" Then
    anvon = "an"
Else
    anvon = "von"
End If

If anvon = "an" Then
    Text1 = adresse
ElseIf anvon = "von" Then
    Text1 = absender
End If


Betreff = MyItem.Subject
Betreff = Replace(Betreff, Chr$(34), "")
Betreff = Replace(Betreff, ":", "_")
Betreff = Replace(Betreff, "<", "_")
Betreff = Replace(Betreff, ">", "_")
Betreff = Replace(Betreff, "?", "_")
Betreff = Replace(Betreff, "/", "_")
Betreff = Replace(Betreff, "\", "_")
Betreff = Replace(Betreff, "*", "_")
Betreff = Replace(Betreff, ".", ".")
Betreff = Replace(Betreff, "|", "-")
Betreff = Replace(Betreff, "[", "-")
Betreff = Replace(Betreff, "]", "-")
Betreff = Replace(Betreff, Chr$(9), " ")
 
' Wenn Betreff länger als 50 Zeichen ist dann Rest löschen
    If Len(Betreff) > 50 Then
        Betreff = Left(Betreff, 50)
    End If
 
 
' Wenn Absender länger als 50 Zeichen ist dann Rest löschen
    If Len(Text1) > 50 Then
        Text1 = Left(Text1, 50)
    End If
   
         
dateiname = Pfad & datum & ", " & anvon & " " & Text1 & " - " & Betreff & ".msg"
ret = fkt_FileSaveAs(dateiname)
If ret <> "" Then
MyItem.SaveAs ret, olMSG
'antw = fkt_setTime(ret, sDate)
End If
End Function

Function fkt_FileSaveAs(sName) As String
'Dim sFilters As String
Dim intError As Integer
' Formattyp-Filter festlegen
Dim strAktDir

With OFName
  'Setzt die Größe der OPENFILENAME Struktur
  .lStructSize = Len(OFName)
  'Der Window Handle ist bei VBA fast immer &O0
  .hwndOwner = &O0
  ' Formattyp-Filter setzen
  .lpstrFilter = "Nachrichtenformat (*.msg)"
  ' Buffer für Dateinamen erzeugen
  .lpstrFile = sName & Space$(1024) & vbNullChar & vbNullChar
  ' Maximale Anzahl der Dateinamen-Zeichen
  .nMaxFile = Len(.lpstrFile)
  ' Buffer für Titel erzeugen
  .lpstrFileTitle = sName
  ' Maximale Anzahl der Titel-Zeichen
  .nMaxFileTitle = 255
    ' Anfangsverzeichnis vorgeben
  .lpstrInitialDir = strAktDir
  .lpstrDefExt = "msg"
  ' Titel des Dialogfester festlegen
  .lpstrTitle = "Datei speichern"
  ' Flags zum Festlegen eines bestimmten Verhaltens,
  ' OFN_LONGNAMES = lange Dateinamen verwenden
  ' OFN_OVERWRITEPROMPT = Abfrage vorm Überschreiben
  .flags = OFN_LONGNAMES Or OFN_OVERWRITEPROMPT
End With
' API aufrufen und evtl. Fehler abfangen
intError = GetSaveFileName(OFName)
If intError <> 0 Then
  fkt_FileSaveAs = Left(OFName.lpstrFile, InStr(1, OFName.lpstrFile, Chr(0)) - 1)
ElseIf intError = 0 Then
  ' Abbruch durch Benutzer oder Fehler
  fkt_FileSaveAs = ""
End If
End Function


------------------
Error in Layer 8

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

RSchulz
Ehrenmitglied V.I.P. h.c.
Teamleader IT-CAD



Sehen Sie sich das Profil von RSchulz an!   Senden Sie eine Private Message an RSchulz  Schreiben Sie einen Gästebucheintrag für RSchulz

Beiträge: 5527
Registriert: 12.04.2007

@Work
Lenovo P510
Xeon E5-1630v4
64GB DDR4
Quadro P2000
256GB PCIe SSD
512GB SSD
SmarTeam V5-6 R2016 Sp04
CATIA V5-6 R2016 Sp05
E3.Series V2019
Altium Designer/Concord 19
Win 10 Pro x64

erstellt am: 02. Okt. 2020 15:17    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für xem 10 Unities + Antwort hilfreich

Hallo,

versuch mal ...

Code:
Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
            "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As LongPtr

Code:

Private Type OPENFILENAME
lStructSize As LongPtr
hwndOwner As LongPtr
hInstance As LongPtr
strFilter As String
strCustomFilter As String
nMaxCustFilter As LongPtr
nFilterIndex As LongPtr
strFile As String
nMaxFile As LongPtr
strFileTitle As String
nMaxFileTitle As LongPtr
strInitialDir As String
strTitle As String
Flags As LongPtr
nFileOffset As Integer
nFileExtension As Integer
strDefExt As String
lCustData As LongPtr
lpfnHook As LongPtr
lpTemplateName As String
End Type

Alle Long müssen als LongPtr deklariert sein.

------------------
MFG
Rick Schulz

Nettiquette (CAD.de)  -  Was ist die Systeminfo?  -  Wie man Fragen richtig stellt.  -  Unities

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

xem
Mitglied
Zeichner


Sehen Sie sich das Profil von xem an!   Senden Sie eine Private Message an xem  Schreiben Sie einen Gästebucheintrag für xem

Beiträge: 832
Registriert: 07.08.2008

Software:
AutoCAD 2014 - 64bit
Windows 7 Pro - 64bit
PDFCreator 1.0.2 - 32bit
Ghostscript 9.0 - 64bit
PDF-XChange Viewer - 64bit
GIMP 2.6.8 - 64bit
MS Office 2010 - 32bit
Opera 12 - 32bit
MacroX - 32bit
7-zip - 64bit
-----------------------
Hardware:
Intel i5 680 3,6GHz @ 4GHz
8GB RAM 1333MHz
nVidia GTX 460 1024MB
Intel SSD 2.5 80GB X25-M
Samsung SyncMaster 245B+
Iiyama ProLite E1900s
Logitech mx518
Logitech G11
Roccat Sense Glacier Blue

erstellt am: 05. Okt. 2020 08:30    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Danke für den Tipp.

Jetzt sagt er mir "Typen unverträglich" und markiert mir "GetSaveFileName".

Code:
' API aufrufen und evtl. Fehler abfangen
intError = GetSaveFileName(OFName)
If intError <> 0 Then
  fkt_FileSaveAs = Left(OFName.lpstrFile, InStr(1, OFName.lpstrFile, Chr(0)) - 1)
ElseIf intError = 0 Then
  ' Abbruch durch Benutzer oder Fehler
  fkt_FileSaveAs = ""
End If
End Function

------------------
Error in Layer 8

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

HenryV
Mitglied
Konstrukteur, Engineering


Sehen Sie sich das Profil von HenryV an!   Senden Sie eine Private Message an HenryV  Schreiben Sie einen Gästebucheintrag für HenryV

Beiträge: 710
Registriert: 18.05.2005

SolidWorks 2018 x64 SP4.0
Dell Precision 5820
Intel Xeon W-2125 4x4GHz
NVIDIA Quadro P2000 5GB
32GB RAM
2x Dell U2412M, 24" TFT
Windows 10 Enterprise x64 1703
Microsoft Office 365 ProPlus
Microsoft Visual Studio Enterprise 2019

erstellt am: 05. Okt. 2020 12:27    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für xem 10 Unities + Antwort hilfreich

Hallo

Ich hab das mal getestet, und mit dieser Version funktioniert es im 64bit.

Code:
Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
            "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Code:
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As LongPtr
    hInstance As LongPtr
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As LongPtr
    lpTemplateName As String
'#if (_WIN32_WINNT >= 0x0500)
    pvReserved As LongPtr
    dwReserved As Long
    FlagsEx As Long
'#endif // (_WIN32_WINNT >= 0x0500)
End Type

------------------
21 ist nur die halbe Antwort.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

xem
Mitglied
Zeichner


Sehen Sie sich das Profil von xem an!   Senden Sie eine Private Message an xem  Schreiben Sie einen Gästebucheintrag für xem

Beiträge: 832
Registriert: 07.08.2008

Software:
AutoCAD 2014 - 64bit
Windows 7 Pro - 64bit
PDFCreator 1.0.2 - 32bit
Ghostscript 9.0 - 64bit
PDF-XChange Viewer - 64bit
GIMP 2.6.8 - 64bit
MS Office 2010 - 32bit
Opera 12 - 32bit
MacroX - 32bit
7-zip - 64bit
-----------------------
Hardware:
Intel i5 680 3,6GHz @ 4GHz
8GB RAM 1333MHz
nVidia GTX 460 1024MB
Intel SSD 2.5 80GB X25-M
Samsung SyncMaster 245B+
Iiyama ProLite E1900s
Logitech mx518
Logitech G11
Roccat Sense Glacier Blue

erstellt am: 05. Okt. 2020 15:11    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Zitat:
Original erstellt von HenryV:
[i]Hallo

Ich hab das mal getestet, und mit dieser Version funktioniert es im 64bit.


läuft, besten Dank

------------------
Error in Layer 8

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Anzeige.:

Anzeige: (Infos zum Werbeplatz >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!

Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2020 CAD.de | Impressum | Datenschutz