| ActiveSheet.ChartObjects, ActiveChart.ChartArea |
| |
| |
| Dim container As Chart | |
| Dim containerbok As Workbook | |
| Dim Obnavn As String | |
| Dim Sourcebok As Workbook | |
| |
| Function SelectArea() As String | |
| Dim Internrange As Range | |
| On Error GoTo Brutt | |
| Set Internrange = Application.InputBox("Select " _ | |
| & "range to be photographed:", "Picture Selection", _ | |
| Selection.AddressLocal, Type:=8) | |
| SelectArea = Internrange.Address | |
| Exit Function | |
| Brutt: | |
| SelectArea = "A1" | |
| End Function | |
| |
| Function sShortname(ByVal Orrginal As String) As String | |
| Dim iii As Integer | |
| sShortname = "" | |
| For iii = 1 To Len(Orrginal) | |
| If Mid(Orrginal, iii, 1) <> " " Then _ | |
| sShortname = sShortname & Mid(Orrginal, iii, 1) | |
| Next | |
| End Function | |
| |
| Private Sub ImageContainer_init() | |
| Workbooks.Add (1) | |
| ActiveSheet.Name = "GIFcontainer" | |
| Charts.Add | |
| ActiveChart.ChartType = xlColumnClustered | |
| ActiveChart.SetSourceData Source:=Worksheets(1).Range("A1") | |
| ActiveChart.Location Where:=xlLocationAsObject, _ | |
| Name:="GIFcontainer" | |
| ActiveChart.ChartArea.ClearContents | |
| Set containerbok = ActiveWorkbook | |
| Set container = ActiveChart | |
| End Sub | |
| |
| Sub MakeAndSizeChart(ih As Integer, iv As Integer) | |
| Dim Hincrease As Single | |
| Dim Vincrease As Single | |
| Obnavn = Mid(ActiveChart.Name, Len(ActiveSheet.Name) + 1) | |
| Hincrease = ih / ActiveChart.ChartArea.Height | |
| ActiveSheet.Shapes(Obnavn).ScaleHeight Hincrease, _ | |
| msoFalse, msoScaleFromTopLeft | |
| Vincrease = iv / ActiveChart.ChartArea.Width | |
| ActiveSheet.Shapes(Obnavn).ScaleWidth Vincrease, _ | |
| msoFalse, msoScaleFromTopLeft | |
| End Sub | |
| |
| Public Sub GIF_Snapshot() | |
| Dim varReturn As Variant | |
| Dim MyAddress As String | |
| Dim SaveName As Variant | |
| Dim MySuggest As String | |
| Dim Hi As Integer | |
| Dim Wi As Integer | |
| Dim Suffiks As Long | |
| |
| Set Sourcebok = ActiveWorkbook | |
| MySuggest = sShortname(ActiveSheet.Name) | |
| ImageContainer_init | |
| Sourcebok.Activate | |
| MyAddress = SelectArea | |
| If MyAddress <> "A1" Then | |
| SaveName = Application.GetSaveAsFilename( _ | |
| initialfilename: =MySuggest _ | |
| & ".gif", fileFilter:="Gif Files (*.gif), *.gif") | |
| Range(MyAddress).Select | |
| Selection.CopyPicture Appearance:=xlScreen, _ | |
| Format:=xlBitmap | |
| If SaveName = False Then | |
| GoTo Avbryt | |
| End If | |
| If InStr(SaveName, ".") Then SaveName _ | |
| = Left(SaveName, InStr(SaveName, ".") - 1) | |
| Selection.CopyPicture Appearance:=xlScreen, _ | |
| Format:=xlBitmap | |
| Hi = Selection.Height + 4 'adjustment for gridlines | |
| Wi = Selection.Width + 6 'adjustment for gridlines | |
| containerbok.Activate | |
| ActiveSheet.ChartObjects(1).Activate | |
| MakeAndSizeChart ih:=Hi, iv:=Wi | |
| ActiveChart.Paste | |
| ActiveChart.Export Filename:=LCase(SaveName) & _ | |
| ".gif", FilterName:="GIF" | |
| ActiveChart.Pictures(1).Delete | |
| Sourcebok.Activate | |
| End If | |
| Avbryt: | |
| On Error Resume Next | |
| Application.StatusBar = False | |
| containerbok.Saved = True | |
| containerbok.Close | |
| End Sub | |
| |
zurück