Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1664to1668
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Fehler wegen 64 Bit bei Makro

Fehler wegen 64 Bit bei Makro
09.01.2019 12:53:53
Michael
Hallo Zusammen,
ich verwendete ein Excelmakro, wo ich die makierten Zellen, als Bild abspeichern konnt.
Nun habe ich das System gewechselt, und jetzt bringt er mir eine Fehlermeldung bezüglich der 64 Bit. Das Makro ist im oberen Teil auch rot makiert.
Habe dann mal andere Makros gesucht, aber hier wird mir leider immer nur ein weißes Feld gespeichert als JPG. Also leider auch nicht hilfreich.
Gruß Michael
Option Explicit
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) 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 Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
ByRef PicDesc As uPicDesc, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPicture) As Long
Declare Function CopyEnhMetaFile Lib "gdi32.dll" Alias "CopyEnhMetaFileA" ( _
ByVal hemfSrc As Long, _
ByVal lpszFile As String) As Long
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 MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
ByVal DirPath As String) As Long
------------------------------------------------------
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
lngSize As Long
lngType As Long
lnghPic As Long
lnghPal As Long
End Type
Private Const E_ABORT = &H80004004
Private Const E_ACCESSDENIED = &H80070005
Private Const E_FAIL = &H80004005
Private Const E_HANDLE = &H80070006
Private Const E_INVALIDARG = &H80070057
Private Const E_NOINTERFACE = &H80004002
Private Const E_NOTIMPL = &H80004001
Private Const E_OUTOFMEMORY = &H8007000E
Private Const E_POINTER = &H80004003
Private Const E_UNEXPECTED = &H8000FFFF
Private Const S_OK = &H0
Private Const CF_BITMAP = 2
Private Const CF_PALETTE = 9
Private Const CF_ENHMETAFILE = 14
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const FOLDER_NAME = "H:\"
Private Const FILE_NAME = "Angebot.jpg"
Public Sub Angebot_speichern()
Dim vntPicture As Variant
Dim lngReturn As Long
Selection.CopyPicture xlScreen, xlBitmap
Set vntPicture = Paste_Picture(xlBitmap)
If Not vntPicture Is Nothing Then
lngReturn = MakeSureDirectoryPathExists(FOLDER_NAME)
If lngReturn = 0 Then
MsgBox "Unalble to create folder: '" & FOLDER_NAME & "'.", vbCritical, "Error"
Else
stdole.StdFunctions.SavePicture vntPicture, FOLDER_NAME & FILE_NAME
End If
Else
MsgBox "Not possible to save picture.", vbCritical, "Error"
End If
End Sub
Function Paste_Picture(Optional lXlPicType As Long = xlPicture) As IPicture
Dim lngReturn As Long, hPtr As Long, hPal As Long
Dim lngPicType As Long, hCopy As Long
lngPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
If IsClipboardFormatAvailable(lngPicType) 0 Then
lngReturn = OpenClipboard(Application.hWnd)
If lngReturn > 0 Then
hPtr = GetClipboardData(lngPicType)
If lngPicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
Call CloseClipboard
If hPtr 0 Then Set Paste_Picture = Create_Picture(hCopy, 0, lngPicType)
End If
End If
End Function
Private Function Create_Picture( _
ByVal lnghPic As Long, _
ByVal lnghPal As Long, _
ByVal lngPicType As Long) As IPicture
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4
Dim lngReturn As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
With IID_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 uPicInfo
.lngSize = Len(uPicInfo)
.lngType = PICTYPE_BITMAP
.lnghPic = lnghPic
.lnghPal = lnghPal
End With
lngReturn = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
If lngReturn  0 Then MsgBox "Error occure" & OLEError(lngReturn), vbCritical, "Error"
Set Create_Picture = IPic
End Function

Private Function OLEError(lErrNum As Long) As String
Select Case lErrNum
Case E_ABORT:        OLEError = " Aborted"
Case E_ACCESSDENIED: OLEError = " Access Denied"
Case E_FAIL:        OLEError = " General Failure"
Case E_HANDLE:      OLEError = " Bad/Missing Handle"
Case E_INVALIDARG:  OLEError = " Invalid Argument"
Case E_NOINTERFACE:  OLEError = " No Interface"
Case E_NOTIMPL:      OLEError = " Not Implemented"
Case E_OUTOFMEMORY:  OLEError = " Out of Memory"
Case E_POINTER:      OLEError = " Invalid Pointer"
Case E_UNEXPECTED:  OLEError = " Unknown Error"
Case S_OK:          OLEError = " Success!"
End Select
End Function

13
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
…Dann musst du das auch in den Declare-Anweisgg …
09.01.2019 13:23:39
Luc:-?
…berücksichtigen, Michael;
steht sogar in der VBE-Hilfe zu Declare und immer wieder mal in Forumsbeiträgen, so erst kürzlich!
Gruß, Luc :-?
AW: Fehler wegen 64 Bit bei Makro
09.01.2019 13:46:07
Nepumuk
Hallo Michael,
teste mal. Wenn es nicht klappt, dann müssen wir auf GDI umschalten. Ich habe mitbekommen dass CopyImage unter 64 Bit nicht klappt.
Option Explicit

Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" ( _
    ByVal wFormat As Long) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
    ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" ( _
    ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
    ByRef PicDesc As uPicDesc, _
    ByRef RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, _
    ByRef IPic As IPictureDisp) As Long
Private Declare PtrSafe Function CopyEnhMetaFileA Lib "gdi32.dll" ( _
    ByVal hemfSrc As Long, _
    ByVal lpszFile As String) As LongPtr
Private Declare PtrSafe Function CopyImage Lib "user32.dll" ( _
    ByVal handle As LongPtr, _
    ByVal un1 As Long, _
    ByVal n1 As Long, _
    ByVal n2 As Long, _
    ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
    ByVal DirPath As String) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" ( _
    ByVal lpsz As Any, _
    ByRef pCLSID As GUID) As Long

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

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

Private Const E_ABORT = &H80004004
Private Const E_ACCESSDENIED = &H80070005
Private Const E_FAIL = &H80004005
Private Const E_HANDLE = &H80070006
Private Const E_INVALIDARG = &H80070057
Private Const E_NOINTERFACE = &H80004002
Private Const E_NOTIMPL = &H80004001
Private Const E_OUTOFMEMORY = &H8007000E
Private Const E_POINTER = &H80004003
Private Const E_UNEXPECTED = &H8000FFFF
Private Const S_OK = &H0

Private Const CF_BITMAP = 2
Private Const CF_PALETTE = 9
Private Const CF_ENHMETAFILE = 14
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const GUID_IPICTUREDISP As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"

Private Const FOLDER_NAME = "H:\"
Private Const FILE_NAME = "Angebot.bmp"

Public Sub Angebot_speichern()
    
    Dim objPicture As IPictureDisp
    Dim lngReturn As Long
    
    Selection.CopyPicture xlScreen, xlBitmap
    
    Set objPicture = Paste_Picture(xlBitmap)
    If Not objPicture Is Nothing Then
        lngReturn = MakeSureDirectoryPathExists(FOLDER_NAME)
        If lngReturn = 0 Then
            MsgBox "Unalble to create folder: '" & FOLDER_NAME & "'.", vbCritical, "Error"
        Else
            stdole.StdFunctions.SavePicture objPicture, FOLDER_NAME & FILE_NAME
        End If
    Else
        MsgBox "Not possible to save picture.", vbCritical, "Error"
    End If
    
End Sub

Function Paste_Picture(Optional lXlPicType As Long = xlPicture) As IPictureDisp
    
    Dim lngReturn As Long, hPtr As LongPtr, hPal As Long
    Dim lngPicType As Long, hCopy As LongPtr
    
    lngPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
    If IsClipboardFormatAvailable(lngPicType) <> 0 Then
        lngReturn = OpenClipboard(Application.hwnd)
        If lngReturn > 0 Then
            hPtr = GetClipboardData(lngPicType)
            If lngPicType = CF_BITMAP Then
                hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            Else
                hCopy = CopyEnhMetaFileA(hPtr, vbNullString)
            End If
            Call CloseClipboard
            If hPtr <> 0 Then Set Paste_Picture = Create_Picture(hCopy, 0, lngPicType)
        End If
    End If
    
End Function

Private Function Create_Picture( _
        ByVal lnghPic As LongPtr, _
        ByVal lnghPal As Long, _
        ByVal lngPicType As Long) As IPictureDisp

    
    Const PICTYPE_BITMAP = 1
    Const PICTYPE_ENHMETAFILE = 4
    
    Dim lngReturn As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPictureDisp
    
    Call CLSIDFromString(StrPtr(GUID_IPICTUREDISP), IID_IDispatch)
    
    With uPicInfo
        .lngSize = Len(uPicInfo)
        .lngType = PICTYPE_BITMAP
        .lnghPic = lnghPic
        .lnghPal = lnghPal
    End With
    
    lngReturn = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
    If lngReturn <> 0 Then MsgBox "Error occure" & OLEError(lngReturn), vbCritical, "Error"
    Set Create_Picture = IPic
    
End Function

Private Function OLEError(lErrNum As Long) As String
    
    Select Case lErrNum
        Case E_ABORT: OLEError = " Aborted"
        Case E_ACCESSDENIED: OLEError = " Access Denied"
        Case E_FAIL: OLEError = " General Failure"
        Case E_HANDLE: OLEError = " Bad/Missing Handle"
        Case E_INVALIDARG: OLEError = " Invalid Argument"
        Case E_NOINTERFACE: OLEError = " No Interface"
        Case E_NOTIMPL: OLEError = " Not Implemented"
        Case E_OUTOFMEMORY: OLEError = " Out of Memory"
        Case E_POINTER: OLEError = " Invalid Pointer"
        Case E_UNEXPECTED: OLEError = " Unknown Error"
        Case S_OK: OLEError = " Success!"
    End Select
    
End Function

Gruß
Nepumuk
Anzeige
AW: Fehler wegen 64 Bit bei Makro
09.01.2019 20:10:13
Michael
Hallo Nepumuk,
auf der alten Version läuft es durch. Im neuen bleibt er aber hängen in
Function Paste_Picture(Optional lXlPicType As Long = xlPicture) As IPictureDisp
mit dem Hinweis "Fehler beim Kompilieren: Typen unverträglich.
Habe auch die Info gefunden das ich PtrSafe einsetzten muss vor Function
Gruß Foxi
AW: Fehler wegen 64 Bit bei Makro
09.01.2019 20:14:09
Nepumuk
Hallo,
hast du den kompletten Code von mir übernommen oder nur Teile davon?
Gruß
Nepumuk
AW: Fehler wegen 64 Bit bei Makro
09.01.2019 20:22:36
Michael
Hi,
den kompletten Code.
Gruß Michael
AW: Fehler wegen 64 Bit bei Makro
09.01.2019 20:26:29
Nepumuk
Hallo Michael,
dann weiß ich auch nicht weiter, ich habe kein 64Bit Office.
Gruß
Nepumuk
Anzeige
AW: Fehler wegen 64 Bit bei Makro
09.01.2019 20:47:20
Nepumuk
Hallo Michael,
entschuldige dass die letzte Antwort von mir etwas schroff war.
Tritt der Fehler beim Aufruf der Funktion auf oder nachdem sie durchgelaufen ist?
Gruß
Nepumuk
AW: Fehler wegen 64 Bit bei Makro
09.01.2019 20:52:55
Michael
Hi Nepumuk,
Du, wie ich sehe schreibst Du ja hier sehr viel. Und ich kenne es das man da mal genervt ist.
Ich starte das Makro und es kommt kurz darauf die Meldung.
Gruß Michael
AW: Fehler wegen 64 Bit bei Makro
09.01.2019 21:03:56
Nepumuk
Hallo Michael,
geh mal in den VBA-Editor setz den Cursor in die Prozedur Angebot_speichern und steppe mit F8 durch den Code. Was ist die Zeile vor dem Fehler?
Diese?
Set objPicture = Paste_Picture(xlBitmap)
Gruß
Nepumuk
Anzeige
AW: Fehler wegen 64 Bit bei Makro
09.01.2019 21:14:06
Michael
Hi Nepumuk,
genau so wie Du es geschrieben hast. Die Set objPicture = Paste_Picture(xlBitmap) nimmt er, und dann erscheint der Fehler.
Gruß Michael
AW: Fehler wegen 64 Bit bei Makro
09.01.2019 21:17:06
Nepumuk
Hallo Michael,
steht in der 1. Programmzeile von Angebot_speichern das:
Dim objPicture As IPictureDisp
oder das:
Dim objPicture As IPicture
?
Gruß
Nepumuk
AW: Fehler wegen 64 Bit bei Makro
09.01.2019 21:24:05
Michael
Hi Nepumuk,
da steht Dim objPicture As IPictureDisp
Gruß Michael
AW: Fehler wegen 64 Bit bei Makro
09.01.2019 21:28:50
Nepumuk
Hallo Michael,
dann weiß ich wirklich nicht weiter. Die Variable und die Funktion sind vom selben Objekttyp das muss normalerweise gehen. Ich versteh nicht warum es nicht funktioniert. Office 64Bit ist einfach Mist.
Gruß
Nepumuk
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige