UserForm - Save - TIF - GIF - JPG!

A user form is to be stored as a file. There are the formats "TIF", "GIF" and "JPG". The problem is over "PowerPoint" solved. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in "UserForm1, UserForm2 and Module1".


Eine UserForm soll als Datei gespeichert werden. Es gibt die Formate "TIF", "GIF" und "JPG". Das Problem wird über "PowerPoint" gelöst. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgende Code gehört in "UserForm1, UserForm2 und Modul1".


Option Explicit
Private Declare Function MapVirtualKey Lib "user32" _
Alias "MapVirtualKeyA" (ByVal wCode As Long, _
ByVal wMapType As Long) As Long
Private Declare Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Sub CommandButton1_Click()
'vbKeySnapshot -> Print = &H2C and ALT = &H12
UserForm2.Show
Me.Repaint
keybd_event &H12, MapVirtualKey(&H12, 0), 0, 0
keybd_event &H2C, 0, 0, 0
DoEvents
keybd_event &H12, MapVirtualKey(&H12, 0), 2, 0
Call UF_PP
Unload Me
If Not UserForm2 Is Nothing Then Unload UserForm2
UserForm1.Show
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub UserForm_Activate()
Me.OptionButton2.Value = True
Me.CheckBox2.Value = True
Me.CheckBox4.Value = True
Me.ListBox1.AddItem "ListBox1"
Me.ListBox2.AddItem "ListBox2"
End Sub


Option Explicit
Private Sub OptionButton1_Click()
Me.Tag = 1
Me.Hide
End Sub
Private Sub OptionButton2_Click()
Me.Tag = 2
Me.Hide
End Sub
Private Sub OptionButton3_Click()
Me.Tag = 3
Me.Hide
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub


Option Explicit
Public Sub UF_PP()
Dim objPPRange As Object
Dim objPPApp As Object
Dim objSlide As Object
Dim strTMP As String
Dim strEX As String
On Error GoTo Fin
Application.ScreenUpdating = False
strTMP = Sheet1.Cells(1, 1).Text
Select Case UserForm2.Tag
Case 1
strEX = "TIF"
Case 2
strEX = "GIF"
Case 3
strEX = "JPG"
End Select
Set objPPApp = CreateObject("PowerPoint.Application")
With objPPApp
.Visible = True
.WindowState = 2
.Presentations.Add
.ActivePresentation.Slides.Add 1, 12
Set objSlide = .ActivePresentation.Slides(1)
Set objPPRange = objSlide.Shapes.Paste
With objPPRange
.LockAspectRatio = False
.Width = objSlide.Design.SlideMaster.Width
.Height = objSlide.Design.SlideMaster.Height
.Align 4, True
.Align 1, True
End With
objSlide.Export "D:\Temp\" & strTMP & "." & _
strEX, strEX ' adapt / anpassen
.Quit
End With
Fin:
Application.ScreenUpdating = True
Set objPPRange = Nothing
Set objSlide = Nothing
Set objPPApp = Nothing
End Sub


Option Explicit
Public Sub UF_Show()
UserForm1.Show
End Sub


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...