مشكله عند طباعة الفريم

[إبراهيم ابوليله]

الاخوه الافاضل

عندى مشكله

وهى اننى عند طباعة الفورم

لايتم طباعة الاسم الكامل للفريم

هل هناك حل لهذه المشكله

تقبلو تحياتى

[جعفر الطريبق]

هل تقصد الاسم اللدي على الشريط الأزرق فوق

و هل تستخدم الكود التالي

UserForm1.PrintForm

 

[إبراهيم ابوليله]

هل تقصد الاسم اللدي على الشريط الأزرق فوق

و هل تستخدم الكود التالي

UserForm1.PrintForm

 

اخى جعفر

اقصد

me.frame.capitan

وبالفعل استخدم

UserForm1.PrintForm

تقبل تحياتى

[جعفر الطريبق]

نعم هده مشكلة عند طباعة الفورم ..

قبل بضعة أعوام كنت انشات كودا يستخدم الويندوز API لطباعة WebBrowser  مغروس داخل احدى صفحات الاكسيل ... لقد عدلت نفس الكود بعض الشيئ ليطبع الفورم

أضف الكود التالي داخل موديول الفورم UserForm Module  و فعل الماكرو  CommandButton1_Click :

Private Sub CommandButton1_Click()

1.     Me.PrintMe

End Sub

Option Explicit
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type DOCINFO
    cbSize As Long
    lpszName As String
    lpszOutput As Long
End Type
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHght As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDefaultPrinter Lib "winspool.drv" Alias "GetDefaultPrinterA" (ByVal sPrinterName As String, lPrinterNameBufferSize As Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Any) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function StartDoc Lib "gdi32" Alias "StartDocA" (ByVal hcs As Long, lpDI As DOCINFO) As Long
Private Declare Function EndDoc Lib "gdi32" (ByVal hcs As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Const SRCCOPY As Long = &HCC0020

Private Sub CommandButton1_Click()
    Me.PrintMe
End Sub


Public Sub PrintMe()
    Dim hDCSrc As Long
    Dim hDCMemory As Long
    Dim hPrintDC As Long
    Dim hwnd As Long
    Dim StrechedWidth As Long
    Dim StrechedHeight As Long
    Dim hBmp As Long
    Dim hBmpPrev As Long
    Dim WidthSrc As Long
    Dim HeightSrc As Long
    Dim tRect As RECT
    Dim MyDoc As DOCINFO

    hwnd = FindWindow(vbNullString, Me.Caption)
    GetWindowRect hwnd, tRect
    WidthSrc = tRect.Right - tRect.Left
    HeightSrc = tRect.Bottom - tRect.Top
    If WidthSrc > HeightSrc Then
        StrechedWidth = WidthSrc + 4000
        StrechedHeight = HeightSrc + (4000 * (HeightSrc / WidthSrc))
    Else
        StrechedHeight = HeightSrc + 4000
        StrechedWidth = WidthSrc + (4000 * (WidthSrc / HeightSrc))
    End If
    hDCSrc = GetWindowDC(hwnd)
    hDCMemory = CreateCompatibleDC(hDCSrc)
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    Call BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, 0, 0, SRCCOPY)
    hPrintDC = GetPrinterDC
    If hPrintDC <> 0 Then
        MyDoc.lpszName = "Form_PrintOut"
        MyDoc.lpszOutput = 0
        MyDoc.cbSize = Len(MyDoc)
        Call StartDoc(hPrintDC, MyDoc)
        Call StretchBlt(hPrintDC, 0, 0, StrechedWidth, _
        StrechedHeight, hDCMemory, 0, 0, WidthSrc, HeightSrc, SRCCOPY)
        Call EndDoc(hPrintDC)
        Call DeleteDC(hPrintDC)
    End If
    Call DeleteDC(hDCMemory)
    Call ReleaseDC(hwnd, hDCSrc)
End Sub

Private Function GetPrinterDC() As Long
    Dim sBuffer As String
    Dim sPrinterName As String
    Dim hPrinter As Long
    
    sBuffer = Space(128)
    If GetDefaultPrinter(sBuffer, 128) Then
        sPrinterName = Left(sBuffer, 128 - 1)
        GetPrinterDC = CreateDC("WINSPOOL", sPrinterName, vbNullString, 0&)
    End If
End Function

 

تم تعديل سبتمبر 9, 2015 بواسطه جعفر الطريبق

[إبراهيم ابوليله]

اخى جعفر

تم اتباع الخطوات ولكن حدث الخطأ التالى

 

ارجو التوضيح

تقبل تحياتى

تم تعديل سبتمبر 9, 2015 بواسطه إبراهيم ابوليله

[جعفر الطريبق]

جرب هدا الملف : https://app.box.com/s/hs9uvmo0458b45rgn6ppdmh07ue0a67h

[إبراهيم ابوليله]

اخى جعفر

مشكورا على الرد

واضح اننى لم افهم جيدا مساعدتك من البدايه

فكنت قد وضعت الكود داخل موديول

الاهم

ان الكود واضح انه بعمل جيدا

ولكن فيه مشكله

ايه هى

اننى لدى فورم

به عدد 2 فريم

اريد طباعة الفريم رقم 1 فقط

مع العلم ان الفريم رقم 2 يكون ناحية اليسار

فقمت باخفاء الفريم رقم 2

فقمت بزحزحه الفريم رقم 1 الى ناحية اليسار

وذلك قبل استخدام امر الطباعه

ولكن فوجئت

بطباعة الفريم رقم 2 فقط

ارجو النظر الى الشيت المرفق

تقبل تحياتى

print frame.rar

[جعفر الطريبق]

جرب التعديل التالي

Private Sub CommandButton1_Click()
    Dim Answer As String
    Dim initialWidth As Long
    Dim t As Single
    
    Answer = MsgBox("åá äÑíÏ ØÈÇÚÉ ÇáÈíÇäÇÊ ÇáÈíÇäÇÊ äÚã Çã áÇ", vbYesNo, "ÊäÈíå")
    If Answer = vbYes Then
        Me.Frame1.Left = 4
        Me.Frame2.Visible = False
        Me.CommandButton1.Visible = False
        Me.CommandButton2.Visible = False
        Me.BackColor = &HFFFFFF
        Me.Frame1.BackColor = &HFFFFFF
        initialWidth = Me.Width
        Me.Width = Me.Frame1.Width + 15
        t = Timer
        Do
            DoEvents
        Loop Until Timer - t >= 2
        Me.PrintMe
        Me.Width = initialWidth
        Me.Frame1.Left = 396
        Me.Frame2.Visible = True
        Me.CommandButton1.Visible = True
        Me.CommandButton2.Visible = True
        Me.BackColor = &HE0E0E0
        Me.Frame1.BackColor = &HE0E0E0
        MsgBox "ÊãÊ ÇáØÈÇÚå ", vbOKOnly, "ÊäÈíå"
    ElseIf Answer = vbNo Then
        MsgBox "Êã ÅáÛÇÁ ÚãáíÉ ÇáØÈÇÚå", vbOKOnly, "ÊäÈíå"
    End If
End Sub

 

تم تعديل سبتمبر 10, 2015 بواسطه جعفر الطريبق