[VBA] 사원증만들기(feat. QR코드생성)

출근기록기와 QR코드 사원증을 만들어 보았다.

 

우연치않게 부동산 분양 관련 일을 서포트하는 일을 맡게 되서 이것저것 만들어보고 있다.

 

까이껏~~~

 

일단 핵심 코드는 QR의 생성이다. QR역시 차트의 일환이기 때문에 구글에서 차트api를 제공하고 있다.

"https://chart.googleapis.com/chart?cht=qr&chs=300x300&chl="

여기서 300은 QR의 사이즈를 뜻하고 [ chl= ] 다음에 QR에 삽입할 내용을 적으면 QR스캐너로 해당 QR을 스캔하면 우리가 삽입한 내용이 나오게 된다.

 

 

코드 진행은 크게

1. 모집인 ID로 QR코드를 생성후

2. 사원증 시트에서 해당 사원의 개인정보를 업데이트 한후 사원증에 하나씩 입혀준다

3. 만들어진 사원증을 해당 엑셀매크로가 있는 폴더에 PNG파일로 저장한다.

3. 그리고 다음 QR을 생성을 반복한다..

 

이게 많이 사용될 거 같진 않지만 언제는 많이 쓰여질것 같아서 만들었던가.

귀찮으니까 만드는거지...

 

 

 

Sub 출근기록기()

    hajaform.Left = Selection.Left + Selection.Width + 30 + Application.Left
    hajaform.Top = Selection.Top + hajaform.Height + Application.Top

    hajaform.Show 0

End Sub

Sub del_qr()
    
    Dim sht As Worksheet
    
    Set sht = ActiveSheet
    
    sht.Pictures.Delete      '= 모든 QR삭제
    

End Sub

Sub make_qr()

 Dim pic As Picture
 Dim url$: url = "https://chart.googleapis.com/chart?cht=qr&chs=300x300&chl="
 Dim sht As Worksheet: Set sht = ActiveSheet
 Dim rngA As Range, rngX As Range
 
 For Each rngA In sht.Range([a3], [a3].End(4))
 
    Application.ScreenUpdating = False
    
        Set pic = sht.Pictures.Insert(url & rngA)  '= QR생성후 시트 삽입
        Set rngX = rngA(1, 4)                      '= QR출력위치
           
        insert_pic pic, rngX                       '= 셀에 QR삽입
        
        Sheets("사원증").Activate                  '= 사원증 시트로 이동
        
        Call Macro(rngA, pic, url)                 '= 사원증을 사진파일로..
        
        Sheets("모집인관리대장").Activate          '= 다음 QR생성을 위해 복귀
    
    Application.ScreenUpdating = True
    
 Next rngA
 
 Set pic = Nothing

End Sub

Sub make_qr_each()

 Dim pic As Picture
 Dim url As String: url = "https://chart.googleapis.com/chart?cht=qr&chs=300x300&chl="
 Dim sht As Worksheet: Set sht = ActiveSheet
 Dim rngX As Range
 
    Set rngX = Selection
   
    Set pic = sht.Pictures.Insert(url & rngX(1, -2))   '= 개별 QR만들기
    
    insert_pic pic, rngX
 
 Set pic = Nothing

End Sub

Sub Macro(rngA As Range, pic As Object, url$)

    Dim rng As Range
    Dim sht As Worksheet: Set sht = ActiveSheet
    Dim shp As Shape
    Dim T As String
    
    For Each shp In sht.Shapes                      '= 사원증에 기존 QR코드 삭제
    
        If shp.Name <> "Picture 2" Then shp.Delete  '= 로고 빼고 삭제
    
    Next shp
    
        T = "사원증_" & rngA                        '= 개인정보 출력
        [d5] = rngA.Value
        [d14] = rngA(1, 2)
        [d15] = rngA(1, 3)
        
        Set pic = sht.Pictures.Insert(url & rngA)   '= QR코드 사원증에 출력
        insert_pic pic, [d8:e12]
        
        Set rng = Range("C4:F19")                   '= 사원증을 png로 같은 폴더에 저장
           rng.CopyPicture xlScreen, xlPicture
        With ActiveSheet.ChartObjects.Add(0, 0, rng.Width, rng.Height)
          .ShapeRange.Line.Visible = msoFalse
          .Select
          .Chart.Paste
          .Chart.Export ThisWorkbook.Path & "\" & T & ".png", "PNG"
          .Delete
        End With
       
End Sub

Function insert_pic(pic As Object, rngX As Range)

    pic.Width = rngX.Width - 2
    pic.Height = rngX.Height - 2
    pic.Left = rngX.Left + 2
    pic.Top = rngX.Top + 2
    
End Function

 

출근기록기.zip

0.04MB

오늘도 맛있는 코드 냠냠