[의뢰] 카톡보내기

의뢰자:

1. 카톡으로 자동으로 원하는 내용을 보내고 싶어요

2. https://www.youtube.com/watch?v=IDf03SSg79E 오빠두 강의를 토대로 만들어 주세요

3. 창이 열려져있는 상태가 아닌 닫혀있는 상태에서도 카톡이 발송되게 해주세요

 

일단 구성은 반자동으로 만들었다. 의뢰자에게 실제 전달은 자동과 반자동을 선택할 수 있도록 하였다.

비활성 매크로로 만드는 것도 가능하나 대화창을 모두 활성화 한 후 해야하기 때문에 활성 매크로로 진행하였다.

 

카톡을 보내는 소스는 공개가 힘들것 같아

 VBA 코드만 공개하도록 하겠다.

 

필요하신분들은 연락주길 010-5872-7179

Option Explicit

Sub 카카오톡문자보내기()

    Dim rngx As Range
    Dim rngA As Range
    Dim rngAll As Range
    
    If [B3] = "" Then Exit Sub                              '= 아무런 이름이 없으면 종료
    Set rngAll = Range([B2], [B2].End(4))                   '= 보낼 대상을rngAll 담아라
    
    For Each rngA In rngAll
        rngA = Trim(rngA)                                   '= 카톡이름 앞 뒤로 빈스페이스 삭제
    Next rngA
    
    If MsgBox("문자 형태의 데이터를 보내시겠습니까?", vbYesNo) = vbYes Then
        On Error GoTo haja
        
            Set rngx = Application.InputBox("발송할 영역을 선택하세요", "카카오톡발송", , , , , , 8)
        
        On Error GoTo 0
        
        [f4] = Replace(rngx.Address, "$", "")
        [f5] = "문자"
           
    End If
    
         If MsgBox("현재 파일 저장 후 문자 발송을 시작합니다." & vbCrLf & "진행할까요", vbYesNo) = vbYes Then
        
            ActiveWorkbook.Save
            
            Shell "C:\카카오문자보내기\kakao(문자).exe"     '= 카카오문자보내기 호출
            
        Else
        
            Exit Sub
        
        End If
haja:
    
End Sub

Option Explicit
Dim fileName As String
Dim rngx As Range
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    
    If Intersect(Target, [m2]) Is Nothing Then GoTo haja      '= 가로형 사진
       With Application.FileDialog(msoFileDialogFilePicker)
           .Show
    
           If .SelectedItems.Count = 0 Then
               Exit Sub
           Else
               fileName = .SelectedItems(1)
           End If
       End With

    Set rngx = [m2].MergeArea
    Call InsertPic(rngx)
    Cancel = True
haja:
    If Intersect(Target, [w2]) Is Nothing Then GoTo haja1      '= 세로형 사진
       With Application.FileDialog(msoFileDialogFilePicker)
           .Show
    
           If .SelectedItems.Count = 0 Then
               Exit Sub
           Else
               fileName = .SelectedItems(1)
           End If
       End With

    Set rngx = [w2].MergeArea
    Call InsertPic(rngx)
    Cancel = True
haja1:
 If Intersect(Target, [m21]) Is Nothing Then Exit Sub           '= 정사각형 사진
       With Application.FileDialog(msoFileDialogFilePicker)
           .Show
    
           If .SelectedItems.Count = 0 Then
               Exit Sub
           Else
               fileName = .SelectedItems(1)
           End If
       End With

    Set rngx = [m21].MergeArea
    Call InsertPic(rngx)
    Cancel = True
End Sub

Sub InsertPic(rngx As Range)

    With ActiveSheet.Pictures.Insert(fileName).ShapeRange
        .LockAspectRatio = msoFalse
        .Height = rngx.Height
        .Width = rngx.Width
        .Left = rngx.Left
        .Top = rngx.Top
    End With
        [f4] = Replace(rngx.Address, "$", "")                   '= 보낼범위에 절대값 바꾸기
        [f5] = "그림"                                           '= 발송방법 문자 / 그림
        

End Sub

사진 추가하는 구문