Range in JPG speichern
04.12.2015 11:23:20
baschti007
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