Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
232to236
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
232to236
232to236
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

gif snapshot + email

gif snapshot + email
16.03.2003 16:17:03
Thorsten
Hallo nochmal ich :)

hab hier zwei funktionierende scripts. eins macht einen screenshot und speichert es als gif und das andere versendet eine datei per email.

ich möchte nun diese beiden scripts zusammenführen. die variabel aus dem bildscript soll an das andere script zum attach übergeben werden.

-----------

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 + 0 'adjustment for gridlines
Wi = Selection.Width + 2 '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

----------------------

Sub email_versenden()
Dim olApp As Outlook.Application
Dim myMail As MailItem
Set olApp = CreateObject("Outlook.Application")
Set myMail = olApp.CreateItem(olMailItem)
With myMail
.Recipients.Add "morgano@gmx.net"
.Attachments.Add "e:\test.gif"
.Subject = "Kostenvoranschlag"
.Body = "Guten Tag, " & vbCr & vbCr
.DeleteAfterSubmit = True
.Send
End With
End Sub

attachment.add soll nun also die variable savename erhalten.

am besten ist natürlich das ganze script oben einzubaun, doch sind alle versuche gescheitert bisher

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Re: gif snapshot + email
16.03.2003 17:12:25
Knut

Nur die Varibale:
Dim SaveName As Variant
auf Modulebene deklarieren
und am Ende des ersten Makro
Call email_versenden
Knut


Re: gif snapshot + email
16.03.2003 17:41:37
Thorsten

wenn ich am ende des ersten makro

Call email_versenden
eintrage bekomm ich direkt einen fehler aus dem emailversandscript bei zeile

Dim olApp As Outlook.Application

benutzerdefinierter Typ nicht definiert


ich hab call email_versenden mal hier eingetragen:


MakeAndSizeChart ih:=Hi, iv:=Wi
ActiveChart.Paste
ActiveChart.Export Filename:=LCase(SaveName) & _
".gif", FilterName:="GIF"
ActiveChart.Pictures(1).Delete
Sourcebok.Activate


End If

call email_versenden

Avbryt:
On Error Resume Next
Application.StatusBar = False
containerbok.Saved = True
containerbok.Close
End Sub

war das richtig hier?
savename ist ja schon deklariert.

Anzeige
Re: gif snapshot + email
16.03.2003 18:05:04
Knut

Hast du die Variable im Deklarationsteil(über der ersten Sub)
deklariert?
Knut

ja ist gemacht
16.03.2003 19:40:29
Thorsten

der code sieht jetzt so aus

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 + 0 'adjustment for gridlines
Wi = Selection.Width + 2 '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

Call email_versenden
Avbryt:
On Error Resume Next
Application.StatusBar = False
containerbok.Saved = True
containerbok.Close
End Sub

Sub email_versenden()
Dim olApp As Outlook.Application
Dim myMail As MailItem
Dim Savename As Variant
Set olApp = CreateObject("Outlook.Application")
Set myMail = olApp.CreateItem(olMailItem)

Empfaenger = Cells(9, 2)

'ausgeblendet für Dateiauswahl solange Savename nicht übergeben wird
'Filename = Application.GetOpenFilename(FileFilter:="Bild-Dateien (*.gif), *.gif", MultiSelect:=True)

With myMail
.Recipients.Add Empfaenger
.Attachments.Add Savename
.Subject = "Kostenvoranschlag"
.Body = "Guten Tag, " & vbCr & vbCr
.DeleteAfterSubmit = True
.Send
End With
End Sub

der fehler ercheint sobald die zweite sub aufgerufen wird

Dim olApp As Outlook.Application

Anzeige
Re: ja ist gemacht
16.03.2003 19:53:28
Knut

Die Variable ist ja noch immer innerhalb der ersten Sub, sie gehört aber darüber, damit sie für das gesamte Modul gilt!
Knut

habs geändert - geht leider noch nciht
16.03.2003 20:22:09
Thorsten

danke hab nicht gewusst das das auch geht.

jetzt steht die variable ganz oben.

ich bekomme aber dennoch eine fehlermeldung
"die methode 'add' für das Object 'attachments' ist fehlgeschlagen.

wenn ich die variable bei den subs rauslösche erscheitn die fehelrmeldung

outlook kann diese datei nicht finden.

sag mir doch bitte noch wo diese Vaiable genau deklariert werden muss.

zur zeit ist es so:

Dim container As Chart
Dim containerbok As Workbook
Dim Obnavn As String
Dim Sourcebok As Workbook
Dim Savename As Variant

Function SelectArea() As String
Dim Internrange As Range
On Error GoTo Brutt
Set Internrange = Application.InputBox("Wähle Bereich aus und drücke ok oder drücke abbrechen um das ganze Blatt direkt zu speichern", "Picture Selection", _
Selection.AddressLocal, Type:=8)
SelectArea = Internrange.Address
Exit Function
Brutt:
SelectArea = "A1:i60"
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 + 0 'adjustment for gridlines
Wi = Selection.Width + 2 '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

Call email_versenden
Avbryt:
On Error Resume Next
Application.StatusBar = False
containerbok.Saved = True
containerbok.Close
End Sub

Sub email_versenden()
Dim olApp As Outlook.Application
Dim myMail As MailItem
'Dim Savename As Variant
Set olApp = CreateObject("Outlook.Application")
Set myMail = olApp.CreateItem(olMailItem)

Empfaenger = Cells(9, 2)

'ausgeblendet für Dateiauswahl solange Savename nicht übergeben wird
'Filename = Application.GetOpenFilename(FileFilter:="Bild-Dateien (*.gif), *.gif", MultiSelect:=True)

With myMail
.Recipients.Add Empfaenger
.Attachments.Add Savename
.Subject = "Kostenvoranschlag"
.Body = "Guten Tag, " & vbCr & vbCr
.DeleteAfterSubmit = True
.Send
End With
End Sub

Anzeige
Re: habs geändert - geht leider noch nciht
16.03.2003 20:46:19
Knut

Tut mir Leid, ich benutze Outlook nicht und kann es nicht probieren.
Knut

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige