Create Identity card using VBA Macros
Sub ExportDataIntoUserform()
Dim FD As FileDialog
Set FD = Application.FileDialog(msoFileDialogFolderPicker)
FD.Show
Dim FolderPath As String
FolderPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
Dim PictureName As String
PictureName = Dir(FolderPath & "*.*")
Do While PictureName <> ""
UserForm1.ListBox1.AddItem PictureName
PictureName = Dir
Loop
UserForm1.TextBox4.Value = FolderPath
UserForm1.Show
End Sub
Sub Create_Identity_Card_Of_Student_Or_Employee()
On Error Resume Next
Dim SH As Worksheet
Set SH = ActiveSheet
ActiveWindow.DisplayGridlines = False
SH.Pictures(SH.Range("B3").Value).Delete
SH.Range("B2:F17").Clear
With SH.Range("B3:F3")
.Merge
.Value = UserForm1.TextBox1.Value
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Size = 15
.Font.ColorIndex = 9
.Font.Name = "Calibri"
.Font.Bold = True
End With
SH.Range("B14").Value = "School Name:"
SH.Range("D14").Value = UserForm1.TextBox2.Value
SH.Range("B15").Value = "Section:"
SH.Range("D15").Value = UserForm1.TextBox3.Value
SH.Range("B16").Value = "Blood Group:"
SH.Range("D16").Value = UserForm1.TextBox5.Value
Dim PictureName As String
For i = 0 To UserForm1.ListBox1.ListCount - 1
If UserForm1.ListBox1.Selected(i) = True Then
PictureName = UserForm1.ListBox1.List(i)
Exit For
End If
Next
Dim Pic As Picture
'================================
'Insert the Picture Directly by mentioning the path
'Set Pic = SH.Pictures.Insert("D:\ARTICLES\my photo.png")
'================================
Set Pic = SH.Pictures.Insert(UserForm1.TextBox4.Value & PictureName)
Pic.Left = 70
Pic.Top = 50
Pic.Name = UserForm1.TextBox1.Value
Pic.ShapeRange.LockAspectRatio = msoFalse
Pic.Height = 150
Pic.Width = 200
'===============================
'To Provide Boarder to the picture
'Pic.Border.LineStyle = xlContinuous
'Pic.Border.Weight = xlThick
'Pic.Border.ColorIndex = 9
'=================================
SH.Range("B14:D16").Select
With Selection
.HorizontalAlignment = xlLeft
.Font.Size = 15
.Font.ColorIndex = 9
.Font.Name = "Calibri"
.Columns(1).Font.Bold = True
.Columns(3).Font.ColorIndex = 1
End With
Dim CH As ChartObject
With Range("B3:F16")
.BorderAround 1, xlThick, 9
.CopyPicture xlScreen, xlBitmap
Set CH = SH.ChartObjects.Add( _
Left:=.Left, _
Top:=.Top, _
Width:=.Width, _
Height:=.Height)
With CH
.Name = "Abcd"
.Activate
End With
End With
ActiveChart.Paste
FolderPath = UserForm1.TextBox4.Value
CH.Chart.Export FileName:=FolderPath & Left(PictureName, Len(PictureName) - 4) & " IDCard.jpg", filtername:="jpg"
ActiveSheet.ChartObjects("Abcd").Delete
Unload UserForm1
End Sub