طباعة كروت الموظفين (كارنيه الموظف) اكسيل

طباعة كروت الموظفين (كارنيه الموظف) اكسيل

يونيو 19, 2016
بسم الله الرحمن الرحيم


اقدم لكم طريقة لطباعة كروت الموظفين

وهي عن طريق فورم نضع عليه كل متطلبات الكارت

من بيانات وشعار الشركة وصورة الموظف
  
هذه صورة للمثال


تستطيعوا التعديل في البيانات لما يناسب متطلباتكم

خلفية الكارت مصممة بالفوتوشوب

وتم وضع تكتست بوكس واداة صورة لعرض صورة الموظف

الكود المستخدم داخل الملف

 #If VBA7 Then  
   Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long  
   Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long  
   Private Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long  
   Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hWnd As LongPtr) As Long  
 #Else  
   Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long  
   Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long  
   Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long  
   Private Declare Function DrawMenuBar Lib "User32" (ByVal hWnd As Long) As Long  
 #End If  
 Const GWL_STYLE = -16  
 Const WS_CAPTION = &HC00000  
 Const WS_SYSMENU = &H80000  
 Private Sub CommandButton1_Click()  
   Dim x As Long  
   Dim y As Long  
   x = Sheet2.Range("a1").End(xlDown).Value  
   Do  
     If TextBox1.Value >= x Then GoTo 1  
     CommandButton1.Visible = False  
     CommandButton2.Visible = False  
     SpinButton1.Visible = False  
     Me.PrintForm  
     TextBox1.Value = TextBox1.Value + 1  
   Loop  
 1  CommandButton1.Visible = True  
   CommandButton2.Visible = True  
   SpinButton1.Visible = True  
   MsgBox "Êã ØÈÇÚÉ ÇáÈØÇÞÇÊ"  
 End Sub  
 Private Sub CommandButton2_Click()  
   End  
 End Sub  
 Private Sub CommandButton3_Click()  
   CommandButton1.Visible = False  
   CommandButton2.Visible = False  
   CommandButton3.Visible = False  
   SpinButton1.Visible = False  
   Me.PrintForm  
   CommandButton1.Visible = True  
   CommandButton2.Visible = True  
   CommandButton3.Visible = True  
   SpinButton1.Visible = True  
   MsgBox "Êã ØÈÇÚÉ ÇáßÇÑÊ"  
 End Sub  
 Private Sub TextBox1_Change()  
   Dim x As Long  
   Dim MyPath As String  
   x = TextBox1.Value  
   On Error Resume Next  
   TextBox2.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 2, 0)  
   TextBox3.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 5, 0)  
   TextBox4.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 4, 0)  
   TextBox6.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 3, 0)  
   MyPath = ThisWorkbook.Path & "\photo\"  
   If TextBox6.Text = "" Then  
     FullImagePath = MyPath + "1000.jpg"  
     Image1.Picture = LoadPicture(FullImagePath)  
   Else  
     FullImagePath = MyPath + TextBox1.Value  
     On Error GoTo 88  
     Image1.Picture = LoadPicture(MyPath & x & ".jpg")  
 88   If Err Then xx  'MsgBox "ÇáÕæÑÉ ÛíÑ ãæÌæÏÉ ÈãÓÇÑåÇ"  
   End If  
 End Sub  
 Private Sub UserForm_Activate()  
   Dim x As Long  
   Dim MyPath As String  
   x = TextBox1.Value  
   On Error Resume Next  
   TextBox2.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 2, 0)  
   TextBox3.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 5, 0)  
   TextBox4.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 4, 0)  
   TextBox6.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 3, 0)  
   MyPath = ThisWorkbook.Path & "\photo\"  
   If TextBox6.Text = "" Then  
     FullImagePath = MyPath + "1000.jpg"  
     Image1.Picture = LoadPicture(FullImagePath)  
   Else  
     FullImagePath = MyPath + TextBox1.Value  
     On Error GoTo 88  
     Image1.Picture = LoadPicture(MyPath & x & ".jpg")  
 88   If Err Then xx  'MsgBox "ÇáÕæÑÉ ÛíÑ ãæÌæÏÉ ÈãÓÇÑåÇ"  
   End If  
 End Sub  
 Private Sub UserForm_Initialize()  
   Dim lngWindow As Long, lFrmHdl As Long  
   lFrmHdl = FindWindow(vbNullString, Me.Caption)  
   lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE)  
   lngWindow = lngWindow And (Not WS_CAPTION)  
   Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow)  
   Call DrawMenuBar(lFrmHdl)  
 End Sub  
 Private Sub SpinButton1_SpinDown()  
   Dim x As Long  
   On Error Resume Next  
   x = Sheet2.Range("a1").End(xlDown).Value  
   If x = TextBox1.Text Then  
     MsgBox "åÐÇ ÇÎÑ ÓÌá"  
   Else  
     TextBox1.Text = TextBox1.Text + 1  
   End If  
 End Sub  
 Private Sub SpinButton1_SpinUp()  
   Dim x As Long  
   On Error Resume Next  
   x = Sheet2.Range("a2").Value  
   If x = TextBox1.Text Then  
     MsgBox " åÐÇ Çæá ÓÌá"  
   Else  
     TextBox1.Text = TextBox1.Text - 1  
   End If  
 End Sub  
 Sub xx()  
   MsgBox ("ÇáÕæÑÉÛíÑ ãæÌæÏÉÈÇáãÓÇÑ")  
   MyPath = ThisWorkbook.Path & "\photo\"  
   FullImagePath = MyPath + "999.jpg"  
   UserForm1.Image1.Picture = LoadPicture(FullImagePath)  
 End Sub

لتحميل المثال اضغط هنا

اعداد / ياسر العربي

تقبلو تحياتي

http://up.top4top.net/downloadf-170ivrj1-rar.html


الإبتساماتإخفاء

الاشتراك في: تعليقات الرسالة (Atom)