Range in JPG speichern

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
InputBox MsgBox
Bild

Betrifft: Range in JPG speichern
von: baschti007
Geschrieben am: 04.12.2015 11:23:20

Hallo Excel Freunde
Ich habe im Internet diesen Code gefunden der echt super funktioniert. Bis auf das ich bei dem Bild welches in der Range liegt einen Rand hat rechts und unten.
Bekommt man diesen irgend wie weg ?
Gruß Basti
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hWnd As Long, _
ByVal Operation As String, ByVal Filename As String, _
Optional ByVal Parameters As String, _
Optional ByVal Directory As String, _
Optional ByVal WindowStyle As Long _
= vbMinimizedFocus) As Long
Const strPathFileNmame As String = "C:\"
' Pfad- und Dateiname anpassen
Const strExt As String = "jpg"

Public Sub Pic_Range_4()
    Dim objDiagramm As ChartObject
    Dim strVerzeichnis As String
    Dim picGrafik As Picture
    Dim rngRange As Range
    Dim strTMP As String
    On Error GoTo Fin
    strTMP = InputBox("Hallo", "Eingabe!", "Hallo")
    If Trim(strTMP) = "" Then Exit Sub
    If Ordnerwahl(strVerzeichnis) <> "" Then
        If Dir(strVerzeichnis & strTMP & "." & strExt) <> "" Then _
            Kill (strVerzeichnis & strTMP & "." & strExt)
        Set rngRange = Application.InputBox _
            ("Bereich mit der Maus wählen...", _
            " Auswahl!", "P26:T29", , , , , 8)
        Application.ScreenUpdating = False
        rngRange.Copy
        Worksheets.Add
        Set picGrafik = ActiveSheet.Pictures.Paste
        picGrafik.CopyPicture 1, -4147
        Set objDiagramm = ActiveSheet.ChartObjects.Add _
            (0, 0, picGrafik.Width, picGrafik.Height)
        With objDiagramm
            .Chart.Paste
            .Chart.Export strVerzeichnis & strTMP & _
                "." & strExt, strExt
        End With
        Application.DisplayAlerts = False
        ActiveSheet.Delete
    Else
        MsgBox "Es wurde kein Ordner ausgewaehlt!"
    End If
Fin:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set objDiagramm = Nothing
    Set picGrafik = Nothing
    Set rngRange = Nothing
    If Err.Number = 424 Then MsgBox "Rangeauswahl abgebrochen!"
    If Err.Number <> 0 And Not Err.Number = 424 Then
        MsgBox "Fehler: " & Err.Number & _
            " " & Err.Description
    Else
        If Dir(strVerzeichnis & strTMP & "." & strExt) <> "" Then _
            ShellExecute 0, "Open", strVerzeichnis & _
            strTMP & "." & strExt, , , 1
    End If
End Sub

Public Function Ordnerwahl(strOrdner As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
'Oder Pfad in dem die Exceldatei ist
'.InitialFileName = ThisWorkbook.Path & "\"
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strOrdner = .SelectedItems(1)
If Right(strOrdner, 1) <> "\" Then _
strOrdner = strOrdner & "\"
Else
strOrdner = ""
End If
End With
Ordnerwahl = strOrdner
End Function

Bild

Betrifft: AW: Range in JPG speichern
von: selli
Geschrieben am: 04.12.2015 11:32:56
hallo,
dein problem ist als solches im code erstmal nicht erkennbar.
leider fehlt auch jede beschreibung, was genau du unter rand verstehst.
eine mögliche ursache ist jedoch eine formatierung des rahmens der grenzzellen.
ich weiß jetzt nicht genau,welcher rahmen standardmäßig zu einer zelle gehört.
hierbei verhält es sich ähnlich der armlehnen im flugzeug oder kino. jeder hat faktisch nur eine zur verfügung.
gruß
selli

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Range in JPG speichern "