Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1416to1420
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

Tabellenbereich wird nicht aktuell exportiert

Tabellenbereich wird nicht aktuell exportiert
03.04.2015 01:21:53
Alexander
Hallo liebe Experten,
Ich habe folgendes Problem.
Ich Exportiere einen Tabellenbereich als jpeg, in dem Bereich wird über ein Add-In ein DataMatrix Code generiert. Solange ich jeden Datensatz einzeln Exportiere klappt es, aber wenn ich eine Schleife darüber laufen lasse wird immer nur der vor dem Makro start erzeugte Code kopiert.
Hier die Beispiel Datei:
https://www.herber.de/bbs/user/96855.xlsm
Das Add-In kann als Demo Version kostenlos hier geladen werden.
Link zur Seite des Downloads im Netz:
http://www.tec-it.com/de/download/tbarcode-office/Download.aspx
Das ganze soll keine Werbung sein, es ist ein Hilferuf, denn nach mehreren Wochen Suche habe leider noch keine Lösung gefunden.
Ich bin für jeden Tipp dankbar und hoffe Ihr könnt mir Helfen.
Schöne Grüße
Alex

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabellenbereich wird nicht aktuell exportiert
03.04.2015 17:52:28
Nepumuk
Hallo,
wenn es dir nichts ausmacht die Bilder als .bmp zu speichern, dann teste es mal so:
Option Explicit

Private Declare Sub Sleep Lib "kernel32.dll" ( _
    ByVal dwMilliseconds 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 DeleteObject Lib "gdi32.dll" ( _
    ByVal hObject As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" ( _
    ByVal lpsz As Any, _
    ByRef pCLSID As GUID) 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 As Long = 1
Private Const CF_BITMAP As Long = 2
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_COPYRETURNORG As Long = &H4
Private Const GUID_IPICTUREDISP As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"

Private llngCopy As Long

Public Sub Start_alle()
    
    Dim lngRow As Long
    
    Cells(4, 2).Value = 1
    
    'Schleife um alle Bilder zu exportieren
    For lngRow = 1 To Cells(Rows.Count, 4).End(xlUp).Row - 1
        
        Cells(4, 2).Value = lngRow
        
        Call BildExp
        
    Next n
    
    Cells(4, 2).Value = 1
    
End Sub

Public Sub Start_einzeln()
    Dim letzteZeile As Long
    
    'letzte Zeile ermitteln
    letzteZeile = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row - 1
    
    'Vergleich ob datesatz vorhanden
    If letzteZeile < Cells(4, 2).Value Then
        MsgBox "Der Datensatz Nummer " & Cells(4, 2).Value & " ist nicht vorhanden!"
        Exit Sub
    Else
        Call BildExp
    End If
    Cells(4, 2).Value = Cells(4, 2).Value + 1
    
End Sub

Private Function Paste_Picture() As IPictureDisp
    
    Dim lngReturn As Long, lngPointer As Long
    
    If Cbool(IsClipboardFormatAvailable(CF_BITMAP)) Then
        
        lngReturn = OpenClipboard(Application.hWnd)
        
        If lngReturn > 0 Then
            
            lngPointer = GetClipboardData(CF_BITMAP)
            
            llngCopy = CopyImage(lngPointer, _
                IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            
            Call CloseClipboard
            
            If lngPointer <> 0 Then Set Paste_Picture = _
                Create_Picture(llngCopy, 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
    
    Call CLSIDFromString(StrPtr( _
        GUID_IPICTUREDISP), udtID_IDispatch)
    
    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
    
    Set objPicture = Nothing
    
End Function

Public Sub BildExp()
    
    Dim objPicture As IPictureDisp
    Dim lngIndex As Long
    
    Call OpenClipboard(Application.hWnd)
    Call EmptyClipboard
    Call CloseClipboard
    
    For lngIndex = 1 To 10
        DoEvents
    Next
    
    Tabelle1.Range("H2:J9").CopyPicture _
        Appearance:=xlScreen, Format:=xlBitmap
    
    Set objPicture = Paste_Picture()
    
    If Not objPicture Is Nothing Then
        Call SavePicture(objPicture, _
            Cells(3, 12).Value & Cells(2, 10).Value & ".bmp")
    Else
        Call MsgBox("Fehler beim Export", vbCritical, "Error")
    End If
    
    Call DeleteObject(llngCopy)
    
End Sub


Gruß
Nepumuk

Anzeige
AW: Tabellenbereich wird nicht aktuell exportiert
03.04.2015 18:38:38
Alexander
Hallo Nepumunk,
geiler Scheiß
Vielen Dank für die Lösung
Gruß
Alex

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige