Probleme mit MultiPage
06.09.2005 22:58:46
Peter
hab mal zwei kurze Frage, hab gestern sowohl von Ramses einen Code für das erstellen von PDF Dateien eingebaut. Das Prob an der Sache ist, das mein ganzes Prog nur über eine UF-Multipage läuft.
So das ich einen Code von Nepumuk eingebaut bzw. bekommen habe um einen Screenshot der UserForm zu machen, soweit zur Vorgeschichte.
Nun hab ich versucht das ganze einzubauen, nur das komischerweise die falschen Bilder gemacht werden, es werden von der ersten Page 2 Bilder gemacht und die letzte fehlt (insgesamt 5). Habs auch schon mit me.mulitpage1.value ausprobiert, da hats gepasst ?
Desweiteren sieht das erste Bild durch die Msgbox so aus. Schwarz absichtlich eingefärbt.
Nun zu meinen Fragen wie kann ich die "richtigen" Pages ansprechen bevor sie "abgelichtet" werden ?
Wie kann ich die korrupte Grafik verhindern ?
'UF
Option Explicit
Public strAuslöser As String
Private Sub CommandButton1_Click()
Dim i As Integer
Dim strMeldung As String
Dim antwort As VbMsgBoxResult
Application.DisplayAlerts = False
Application.ScreenUpdating = False
strMeldung = "Bitte stellen Sie sicher das folgende Punkte erfüllt sind ?" & vbCr _
& "1. Sie haben Acrobat Pro Vers. 6 oder 7 installiert" & vbCr _
& "2. Es wurden die entsprechenden Vereise in der VBA Umgebung auf" & vbCr _
& "Acrobat Distiller / Microsoft Office 10.0 / 11.0 Object Library gesetzt" & vbCr _
& "3. Sie haben unter den Adobe Druckeigenschaften / Schriften an Adobe senden deaktiviert" & vbCr _
& vbCr & "Wollen Sie nun fortsetzten ?"
antwort = MsgBox(strMeldung, vbYesNoCancel, "Überprüfung vor Druck")
If antwort = vbNo Or antwort = vbCancel Then Exit Sub
Call bilder_löschen
For i = 0 To Me.MultiPage1.Pages.Count - 1
If i <> 4 Then
Me.MultiPage1.Value = i
Application.Wait (1000)
Call prcCopyForm
Else
strAuslöser = "CB"
Me.MultiPage1.Value = 4
End If
Next
Call bilder_anpassen
If Sheets("Reporting").Visible <> -1 Then Sheets("Reporting").Visible = -1
If Sheets("Tabelle1").Visible <> 2 Then Sheets("Tabelle1").Visible = 2
Call Print_to_PDF(Sheets("Reporting"))
Sheets("Tabelle1").Visible = -1
Sheets("Reporting").Visible = 2
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub MultiPage1_Change()
If Me.MultiPage1.SelectedItem.Caption <> "Grunddaten" Then
Call aktivieren
Else
Select Case strAuslöser
Case Is <> "CB"
Me.Label70.Visible = False
Me.Hide
Case "CB"
strAuslöser = ""
End Select
End If
End Sub
Option Explicit
Option Private Module
'*******************************************************************************
'* Screenshots der UserForm machen zur Verfügung gestellt von Max aka Nepumuk *
'*******************************************************************************
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 Const KEYEVENTF_KEYUP = &H2
Private Const VK_MENU = &H12
Public Sub prcCopyForm()
Dim intAltScan As Integer
Application.ScreenUpdating = False
intAltScan = MapVirtualKey(VK_MENU, 0&)
keybd_event VK_MENU, intAltScan, 0&, 0&
keybd_event vbKeySnapshot, 0&, 0&, 0&
DoEvents
keybd_event VK_MENU, intAltScan, KEYEVENTF_KEYUP, 0
With Sheets("Reporting")
.Paste
End With
Application.ScreenUpdating = True
End Sub
Sub bilder_löschen()
Dim myshape As Shape
With Sheets("Reporting")
For Each myshape In .Shapes
myshape.Delete
Next
End With
End Sub
Sub bilder_anpassen()
Dim myshape As Shape
Dim myObjSh As Object
Dim intzähl As Integer
Dim strRng As String
With Sheets("Reporting")
For Each myshape In .Shapes
intzähl = intzähl + 1
Set myObjSh = myshape
Select Case intzähl
Case 1: strRng = "A1"
Case 2: strRng = "A34"
Case 3: strRng = "A67"
Case 4: strRng = "A100"
Case 5: strRng = "A133"
End Select
myObjSh.Top = .Range(strRng).Top
myObjSh.Left = .Range(strRng).Left
Set myObjSh = Nothing
Next
End With
End Sub
Vielen Dank und Sry für den langen Text
Peter