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
keybd_event &H12, MapVirtualKey(&H12, 0), 0, 0
keybd_event &H2C, 0, 0, 0
keybd_event &H12, MapVirtualKey(&H12, 0), 2, 0
Call UF_PP
Unload Me
If Not UserForm2 Is Nothing Then Unload UserForm2
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
End Sub
Private Sub OptionButton2_Click()
Me.Tag = 2
End Sub
Private Sub OptionButton3_Click()
Me.Tag = 3
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
.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
End With
Application.ScreenUpdating = True
Set objPPRange = Nothing
Set objSlide = Nothing
Set objPPApp = Nothing
End Sub

Option Explicit
Public Sub UF_Show()
End Sub

Sample 2003

Sample 2007


Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

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