بسم الله الرحمن الرحيم
اقدم لكم طريقة لطباعة كروت الموظفين
وهي عن طريق فورم نضع عليه كل متطلبات الكارت
من بيانات وشعار الشركة وصورة الموظف
هذه صورة للمثال
تستطيعوا التعديل في البيانات لما يناسب متطلباتكم
خلفية الكارت مصممة بالفوتوشوب
وتم وضع تكتست بوكس واداة صورة لعرض صورة الموظف
الكود المستخدم داخل الملف
لتحميل المثال اضغط هنا
اعداد / ياسر العربي
تقبلو تحياتي
http://up.top4top.net/downloadf-170ivrj1-rar.html
#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
