Ei voi muuta sanoa, että kyllä se Excel kaikkeen vääntyy - kokeilkaas nyt vaikka alla olevaa koodia. Tekee dynaamisen kuvan! Siis kun valitun alueen arvot muuttuvat niin päivittyy tieto kuvaankin. Varsinainen kysymys viisaille seuraa sitten koodin jälkeen.
**********
Sub DoCamera()
Dim MyPrompt As String
Dim MyTitle As String
Dim UserRange As Range
Dim OutputRange As Range
Application.ScreenUpdating = True
'Prompt user for range to capture
MyPrompt = "Select the range you would like to capture."
MyTitle = "User Input Required"
On Error Resume Next
Set UserRange = Application.InputBox(Prompt:=MyPrompt, _
Title:=MyTitle, Default:=ActiveCell.Address, Type:=8)
If UserRange Is Nothing Then End
On Error GoTo 0
'Copy range to Clipboard as picture
UserRange.CopyPicture
'Prompt user for range to paste to
MyPrompt = "Select the range on which you would like to paste."
MyTitle = "User Input Required"
On Error Resume Next
Set OutputRange = Application.InputBox(Prompt:=MyPrompt, _
Title:=MyTitle, Default:=ActiveCell.Address, Type:=8)
If OutputRange Is Nothing Then End
On Error GoTo 0
'Paste picture to output range
OutputRange.PasteSpecial
Selection.Formula = UserRange.Address
End Sub
*****
Millainen koodi pitäisi vääntää, että tuon kuvan saisi tallennettua kätsysti gif-muodossa tiedostoksi? Tuo kuvahan on ilmeisesti leikepöydällä koko ajan - jos nyt oikein ymmärrän.
**********
Sub DoCamera()
Dim MyPrompt As String
Dim MyTitle As String
Dim UserRange As Range
Dim OutputRange As Range
Application.ScreenUpdating = True
'Prompt user for range to capture
MyPrompt = "Select the range you would like to capture."
MyTitle = "User Input Required"
On Error Resume Next
Set UserRange = Application.InputBox(Prompt:=MyPrompt, _
Title:=MyTitle, Default:=ActiveCell.Address, Type:=8)
If UserRange Is Nothing Then End
On Error GoTo 0
'Copy range to Clipboard as picture
UserRange.CopyPicture
'Prompt user for range to paste to
MyPrompt = "Select the range on which you would like to paste."
MyTitle = "User Input Required"
On Error Resume Next
Set OutputRange = Application.InputBox(Prompt:=MyPrompt, _
Title:=MyTitle, Default:=ActiveCell.Address, Type:=8)
If OutputRange Is Nothing Then End
On Error GoTo 0
'Paste picture to output range
OutputRange.PasteSpecial
Selection.Formula = UserRange.Address
End Sub
*****
Millainen koodi pitäisi vääntää, että tuon kuvan saisi tallennettua kätsysti gif-muodossa tiedostoksi? Tuo kuvahan on ilmeisesti leikepöydällä koko ajan - jos nyt oikein ymmärrän.
Vastaukset 2
Vanhimmat
ei kovinkaan helppo case koodilla...
Toinen tapa helppo elika tallenna web muodossa ja kuvista tulee automaattisesti kuvatiedosto. Toimii kaikissa office ohjelmissa.
tassa nyt kuitenkin pyytamasi koodi
Moduuliin...
Option Explicit
Public Sub GIF()
Dim Alue As String
Dim Nimi As Variant
Dim Korkeus As Integer
Dim Leveys As Integer
Dim Valinta As Range
Dim KaavionNimi As String
Dim LisไไKorkeus As Double
Dim LisไไLeveys As Double
On Error GoTo lopeta
Application.DisplayAlerts = False
Worksheets("Taul2").Activate
Worksheets("Taul2").Name = "GIFKaavio"
Charts.Add
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Worksheets(1).Range("A1")
ActiveChart.Location Where:=xlLocationAsObject, Name:="GIFKaavio"
ActiveChart.ChartArea.ClearContents
Worksheets("Taul1").Activate
Set Valinta = Application.InputBox("Valitse peilattava alue:", "Kuvan kopiointi", _
Selection.AddressLocal, Type:=8)
Alue = Valinta.Address
Nimi = Application.GetSaveAsFilename(fileFilter:="Gif Files (*.gif), *.gif")
Range(Alue).Select
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
If Nimi = False Then
GoTo lopeta
End If
If InStr(Nimi, ".") Then
Nimi = Left(Nimi, InStr(Nimi, ".") - 1)
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Korkeus = Selection.Height 6
Leveys = Selection.Width 6
Worksheets("GIFKaavio").Activate
ActiveSheet.ChartObjects(1).Activate
KaavionNimi = Mid(ActiveChart.Name, Len(ActiveSheet.Name) 1)
LisไไKorkeus = Korkeus / ActiveChart.ChartArea.Height
ActiveSheet.Shapes(KaavionNimi).ScaleHeight LisไไKorkeus, msoFalse, msoScaleFromTopLeft
LisไไLeveys = Leveys / ActiveChart.ChartArea.Width
ActiveSheet.Shapes(KaavionNimi).ScaleWidth LisไไLeveys, msoFalse, msoScaleFromTopLeft
ActiveChart.Paste
ActiveChart.Export Filename:=LCase(Nimi) & ".gif", FilterName:="GIF"
Worksheets("Taul1").Activate
Range("A1").Select
End If
lopeta:
Worksheets("GIFKaavio").Delete
Worksheets.Add
ActiveSheet.Name = "Taul2"
Worksheets("Taul1").Activate
Range("A1").Select
End Sub
Juu, kätevämpi on komentaa tallentamaan html:nä - ei tule montaakaan riviä koodia.
Eipäs tullut heti mieleen ja sitä paitsi näkyy olevan tuollainen kamera-työkalu Excelin työkaluissakin mutta on vähän piilossa. Löytyy näin:työkalut - mukauta, aktivoi kategoria työkalut ja selaa oikeanpuoleisesta ikkunasta kamera-kuvake valikkoon.