السلام عليكم ورحمة الله وبركاته
أولا أعتذر عن الانقطاع عن المشاركات وذلك لظروف عمل و دراسة
اليوم إنشاء الله سوف نحاول التطرق لكيفية معاينة ورقة العمل قبل الطباعة وذلك من خلال اليوزر فورم كيف ذلك ؟.
تابع معي
أولا نقوم بفتح ملف اكسل ثم نقوم بكتابة بيانات ولتكن على سبيل المثال تقرير حول الانتاج اليوم لمصنع مثلما هو موضح في الصورة 
نفتح محرر الأكواد ونقوم إدراج يوزر فورم وندرج فيه زرين كما هو في الصورة

نقوم بإدراج يوزر فورم2 ونظيف له زرين ومربع لصور كما هو موضح

بعد ذلك نقوم بتكبير اليوزر فورم 2 وكذلك مربع الصورة لكي يتناسب مع حجم الشاشة
نعود لليوزر فورم 1 ونضغط مرتين على زر معاينة قبل الطباعة ونكتب الكود التالي:
Private Sub CommandButton2_Click()
UserForm2.Show
End Sub
وفي زر إظهار ملف الأكسل نكتب الكود التالي:
Private Sub CommandButton5_Click()
UserForm1.Hide
Application.Visible = True
End Sub
وفي اليوزر فورم الثاني نكتب في حدث UserForm_Activate()
الكود التالي:
Private Sub UserForm_Activate()
Application.CutCopyMode = False
Range("a1:l26").Copy
Image1.Picture = PastePicture(xlPicture)
Application.CutCopyMode = True
End Sub
وهذا الكود هو لكي يقوم البرنامج بإلتقاط صورة للمدى المحدد في الكود وعرضها كصورة على اليوزر فور
وفي زر الطباعة نكتب الكود التالي:
[codePrivate Sub CommandButton7_Click()
Application.Visible = True
ActiveSheet.Range("a1:l26").PrintOut copies:=TextBox1.Value
End Sub][/code]
وهذا الكود هو للطباعة والقيمة الموجودة في التكس بوكس هي عدد النسخ التي تريد طباعتها
ثم نقوم بإدراج موديول وننسخ فيه الكود التالي:
'***************************************************************************
'*
'* MODULE NAME: Paste Picture
'* AUTHOR & DATE: STEPHEN BULLEN, Office Automation Ltd
'* 15 November 1998
'*
'* Revisions by JosephP for 64bit compatibility
'*
'* '* DESCRIPTION: Creates a standard Picture object from whatever is on the clipboard.
'* This object can then be assigned to (for example) and Image control
'* on a userform. The PastePicture function takes an optional argument of
'* the picture type - xlBitmap or xlPicture.
'*
'* The code requires a reference to the "OLE Automation" type library
'*
'* The code in this module has been derived from a number of sources
'* discovered on MSDN.
'*
'* To use it, just copy this module into your project, then you can use:
'* Set Image1.Picture = PastePicture(xlPicture)
'* to paste a picture of whatever is on the clipboard into a standard image control.
'*
'* PROCEDURES:
'* PastePicture The entry point for the routine
'* CreatePicture Private function to convert a bitmap or metafile handle to an OLE reference
'* fnOLEError Get the error text for an OLE error code
'***************************************************************************
Option Explicit
Option Compare Text
'Declare the GUID Type structure for the IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'The API Constants needed
Const CF_BITMAP = &H2
Const CF_ENHMETAFILE = &HE
Const CF_METAFILEPICT = &H3
Const CF_PALETTE = &H9
Const IMAGE_BITMAP = &H0
Const IMAGE_ICON = &H1
Const IMAGE_CURSOR = &H2
Const LR_COPYRETURNORG = &H4
#If VBA7 Then
'=================================='
' User-Defined Types for API Calls '
'=================================='
'Declare the Picture Description Type structure
Private Type PICTDESC
Size As Long
Type As Long
hPic As LongPtr 'Holds the handle to a .bmp, .emf, .ico, .wmf file
Data1 As LongPtr 'For a .bmp this holds the pallete handle hPal. For a .wmf this hold the xExt value.
Data2 As LongPtr 'Used only with a .wmf to hold the yExt value.
End Type
'==================================='
' Windows API Function Declarations '
'==================================='
'Does the clipboard contain a bitmap/metafile?
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" _
(ByVal wFormat As Long) As Long
'Open the clipboard to read and write data
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" _
(ByVal hWnd As LongPtr) As Long
'Get a pointer to the bitmap/metafile
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" _
(ByVal wFormat As Long) As LongPtr
'Copy data to the clipboard
Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" _
(ByVal uFormat As Long, ByVal hData As LongPtr) As LongPtr
'Empty the clipboard
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
'Close the clipboard
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" _
(ByRef pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, _
ByRef ppvObj As IPicture) As LongPtr
'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Declare PtrSafe Function CopyEnhMetaFile Lib "GDI32.dll" Alias "CopyEnhMetaFileA" _
(ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As LongPtr
'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
Declare PtrSafe Function CopyImage Lib "user32.dll" (ByVal hImage As LongPtr, ByVal uType As Long, _
ByVal cxDesired As Long, ByVal cyDesired As Long, _
ByVal fuFlags As Long) As LongPtr
Public Function PastePicture(Optional xlPicType As Long = xlPicture) As IPicture
'Some pointers
Dim hClip As Long
Dim hCopy As LongPtr
Dim hObj As LongPtr
Dim hPal As Long
Dim hPicAvail As Long
Dim PicType As Long
Dim RetVal As Long
'Convert the Excel picture type constant to the correct API constant
PicType = IIf(xlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
'Check if the clipboard contains the required format
hPicAvail = IsClipboardFormatAvailable(PicType)
If hPicAvail <> 0 Then
'Get access to the saj clipboard
hClip = OpenClipboard(0&)
If hClip > 0 Then
'Get a handle to the saj object
hObj = GetClipboardData(PicType)
'Create a copy of the saj clipboard image in the appropriate format.
If PicType = CF_BITMAP Then
hCopy = CopyImage(hObj, IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hObj, vbNullString)
End If
'Release the saj clipboard to other programs
RetVal = CloseClipboard
'If there is a handle to the image, convert it into a Picture object and return it
If hObj <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, PicType)
End If
End If
End Function
Private Function CreatePicture(ByVal hPic As LongPtr, ByVal hPal As LongPtr, ByVal PicType) As IPicture
'saj IPicture requires a reference to "OLE Automation"
Dim Ref_ID As GUID
Dim IPic As IPicture
Dim PicInfo As PICTDESC
Dim RetVal As LongPtr
'OLE Picture types
Const PICTYPE_UNINITIALIZED = -1
Const PICTYPE_NONE = 0
Const PICTYPE_BITMAP = 1
Const PICTYPE_METAFILE = 2
Const PICTYPE_ICON = 3
Const PICTYPE_ENHMETAFILE = 4
'Create a UDT to hold the reference to the interface ID (riid).
'IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
'StdPicture GUID {0BE35204-8F91-11CE-9DE3-00AA004BB851}
With Ref_ID
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
'Fill PicInfo structure
With PicInfo
.Size = Len(PicInfo) ' Length of structure.
.Type = IIf(PicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) ' Type of Picture
.hPic = hPic ' Handle to image.
.Data1 = IIf(PicType = CF_BITMAP, hPal, 0&) ' Handle to palette (if bitmap).
.Data2 = 0&
End With
'Create the Picture object.
RetVal = OleCreatePictureIndirect(PicInfo, Ref_ID, True, IPic)
'Check if an error ocurred
If RetVal <> 0 Then
MsgBox "Create Picture Failed - " & GetErrMsg(RetVal)
Set IPic = Nothing
Exit Function
End If
'Return the new Picture object.
Set CreatePicture = IPic
End Function
Private Function GetErrMsg(ErrNum As LongPtr) As String
'OLECreatePictureIndirect return values
Const E_ABORT = &H80004004
Const E_ACCESSDENIED = &H80070005
Const E_FAIL = &H80004005
Const E_HANDLE = &H80070006
Const E_INVALIDARG = &H80070057
Const E_NOINTERFACE = &H80004002
Const E_NOTIMPL = &H80004001
Const E_OUTOFMEMORY = &H8007000E
Const E_POINTER = &H80004003
Const E_UNEXPECTED = &H8000FFFF
Select Case ErrNum
Case E_ABORT
GetErrMsg = " Aborted"
Case E_ACCESSDENIED
GetErrMsg = " Access Denied"
Case E_FAIL
GetErrMsg = " General Failure"
Case E_HANDLE
GetErrMsg = " Bad/Missing Handle"
Case E_INVALIDARG
GetErrMsg = " Invalid Argument"
Case E_NOINTERFACE
GetErrMsg = " No Interface"
Case E_NOTIMPL
GetErrMsg = " Not Implemented"
Case E_OUTOFMEMORY
GetErrMsg = " Out of Memory"
Case E_POINTER
GetErrMsg = " Invalid Pointer"
Case E_UNEXPECTED
GetErrMsg = " Unknown Error"
End Select
End Function
#Else
'=================================='
' User-Defined Types for API Calls '
'=================================='
'Declare the Picture Description Type structure
Private Type PICTDESC
Size As Long
Type As Long
hPic As Long 'Holds the handle to a .bmp, .emf, .ico, .wmf file
Data1 As Long 'For a .bmp this holds the pallete handle hPal. For a .wmf this hold the xExt value.
Data2 As Long 'Used only with a .wmf to hold the yExt value.
End Type
'==================================='
' Windows API Function Declarations '
'==================================='
'Does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" _
(ByVal wFormat As Integer) As Long
'Open the clipboard to read and write data
Private Declare Function OpenClipboard Lib "user32.dll" _
(ByVal hWnd As Long) As Long
'Get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32.dll" _
(ByVal wFormat As Integer) As Long
'Copy data to the clipboard
Private Declare Function SetClipboardData Lib "user32.dll" _
(ByVal uFormat As Long, ByVal hData As Long) As Long
'Empty the clipboard
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
'Close the clipboard
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(ByRef pPictDesc As PICTDESC, ByRef riid As GUID, _
ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Declare Function CopyEnhMetaFile Lib "GDI32.dll" Alias "CopyEnhMetaFileA" _
(ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
Declare Function CopyImage Lib "user32.dll" (ByVal hImage As Long, _
ByVal uType As Long, ByVal cxDesired As Long, _
ByVal cyDesired As Long, ByVal fuFlags As Long) As Long
Public Function PastePicture(Optional xlPicType As Long = xlPicture) As IPicture
'Some pointers
Dim hClip As Long
Dim hCopy As Long
Dim hObj As Long
Dim hPal As Long
Dim hPicAvail As Long
Dim PicType As Long
Dim RetVal As Long
'Convert the Excel picture type constant to the correct API constant
PicType = IIf(xlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
'Check if the clipboard contains the required format
hPicAvail = IsClipboardFormatAvailable(PicType)
If hPicAvail <> 0 Then
'Get access to the clipboard
hClip = OpenClipboard(0&)
If hClip > 0 Then
'Get a handle to the object
hObj = GetClipboardData(PicType)
'Create a copy of the clipboard image in the appropriate format.
If PicType = CF_BITMAP Then
hCopy = CopyImage(hObj, IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hObj, vbNullString)
End If
'Release the clipboard to other programs
RetVal = CloseClipboard
'If there is a handle to the image, convert it into a Picture object and return it
If hObj <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, PicType)
End If
End If
End Function
Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal PicType) As IPicture
'saj IPicture requires a reference to "OLE Automation"
Dim Ref_ID As GUID
Dim IPic As IPicture
Dim PicInfo As PICTDESC
Dim RetVal As Long
'OLE Picture types
Const PICTYPE_UNINITIALIZED = -1
Const PICTYPE_NONE = 0
Const PICTYPE_BITMAP = 1
Const PICTYPE_METAFILE = 2
Const PICTYPE_ICON = 3
Const PICTYPE_ENHMETAFILE = 4
'Create a UDT to hold the reference to the interface ID (riid).
'IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
'StdPicture GUID {0BE35204-8F91-11CE-9DE3-00AA004BB851}
With Ref_ID
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
'Fill PicInfo structure
With PicInfo
.Size = Len(PicInfo) ' Length of structure.
.Type = IIf(PicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) ' Type of Picture
.hPic = hPic ' Handle to image.
.Data1 = IIf(PicType = CF_BITMAP, hPal, 0&) ' Handle to palette (if bitmap).
.Data2 = 0&
End With
'Create the Picture object.
RetVal = OleCreatePictureIndirect(PicInfo, Ref_ID, True, IPic)
'Check if an error ocurred
If RetVal <> 0 Then
MsgBox "Create Picture Failed - " & GetErrMsg(RetVal)
Set IPic = Nothing
Exit Function
End If
'Return the new Picture object.
Set CreatePicture = IPic
End Function
Private Function GetErrMsg(ErrNum As Long) As String
'OLECreatePictureIndirect return values
Const E_ABORT = &H80004004
Const E_ACCESSDENIED = &H80070005
Const E_FAIL = &H80004005
Const E_HANDLE = &H80070006
Const E_INVALIDARG = &H80070057
Const E_NOINTERFACE = &H80004002
Const E_NOTIMPL = &H80004001
Const E_OUTOFMEMORY = &H8007000E
Const E_POINTER = &H80004003
Const E_UNEXPECTED = &H8000FFFF
Select Case ErrNum
Case E_ABORT
GetErrMsg = " Aborted"
Case E_ACCESSDENIED
GetErrMsg = " Access Denied"
Case E_FAIL
GetErrMsg = " General Failure"
Case E_HANDLE
GetErrMsg = " Bad/Missing Handle"
Case E_INVALIDARG
GetErrMsg = " Invalid Argument"
Case E_NOINTERFACE
GetErrMsg = " No Interface"
Case E_NOTIMPL
GetErrMsg = " Not Implemented"
Case E_OUTOFMEMORY
GetErrMsg = " Out of Memory"
Case E_POINTER
GetErrMsg = " Invalid Pointer"
Case E_UNEXPECTED
GetErrMsg = " Unknown Error"
End Select
End Function
#End If
ومن خلال التبويب This Workbook
نختار الحدث open
ونكتب الكود التالي:
Private Sub Workbook_Open()
Application.Visible = False
UserForm1.Show
End Sub
نعود لصفحة العمل ونقوم بإدراج زرأمر ونضغط عليه مرتين و نكتب الكود التالي
Sub زر1_انقر()
Application.Visible = False
UserForm1.Show
End Sub
و عند تنفيذ البرنامج عند المعاينة تظهر بالشكل التالي:

تقبلو تحياتي
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب