기타 사용자정의 함수

내역관련/함수

기타 사용자정의 함수

고추탄 2022. 10. 7. 10:31

'함수모음

Option Explicit
Option Base 1

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long

Private Type BrowseInfo
    Owner As Long
    Root As Long
    pszDisplayName As String
    Title As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Function GetDirectory(Msg) As String
    Dim tBrowseInfo As BrowseInfo
    Dim strPath As String
    Dim r As Long
    Dim x As Long
    Dim lpIDList As Long
    lpIDList = SHBrowseForFolder(tBrowseInfo)
    If (lpIDList) Then
        strPath = Space(512)
        SHGetPathFromIDList ByVal lpIDList, ByVal strPath
        GetDirectory = Left(strPath, InStr(strPath, vbNullChar) - 1)
    End If
End Function

Function Trim_Name(myString) As String
Application.Volatile (True)
Dim MyPos As Integer
Do
MyPos = InStr(1, myString, "\")
myString = Mid(myString, MyPos + 1)
Loop Until MyPos = 0
Trim_Name = myString
End Function

Function Trim_FolderName(sTrwhat) As String
Application.Volatile (True)
Dim MyPos As Integer
Dim i As Integer
Dim myString As String
Dim sTemp As String
myString = sTrwhat
'Len()함수는 문자열의 길이(몇글자)를 반환하는 문자열 함수이다.
'전달받은 문자열의 수만큼 순환한다.
For i = Len(myString) To 1 Step -1
    'mid함수로 한글자씩 변수에 담는다.
     sTemp = Mid(myString, i, 1)
     If sTemp = "\" Then
        myString = Mid(myString, i)
       '주어진 문자열에 대해 OLD TEXT를 NEW TEXT로 교체
        sTrwhat = Replace(sTrwhat, myString, "")
        Exit For
     End If
Next i
Do
       MyPos = InStr(1, sTrwhat, "\")
       sTrwhat = Mid(sTrwhat, MyPos + 1)
Loop Until MyPos = 0
Trim_FolderName = sTrwhat
End Function

Function Trim_FolderPathName(sTrwhat) As String
Application.Volatile (True)
Dim MyPos As Integer
Dim i As Integer
Dim myString As String
Dim sTemp As String
myString = sTrwhat
'Len()함수는 문자열의 길이(몇글자)를 반환하는 문자열 함수이다.
'전달받은 문자열의 수만큼 순환한다.
For i = Len(myString) To 1 Step -1
    'mid함수로 한글자씩 변수에 담는다.
     sTemp = Mid(myString, i, 1)
     If sTemp = "\" Then
        myString = Mid(myString, i)
       '주어진 문자열에 대해 OLD TEXT를 NEW TEXT로 교체
        sTrwhat = Replace(sTrwhat, myString, "")
        Exit For
     End If
Next i
Trim_FolderPathName = sTrwhat
End Function

Function Extract_EachName(Myary)
Application.Volatile (True)
Dim i As Integer
Dim j As Integer
Dim NewFary
Dim aryFinal()
Dim myJudge As Boolean
Dim k As Byte
NewFary = WorksheetFunction.Transpose(Myary)
ReDim aryFinal(3, 1)
aryFinal(1, 1) = NewFary(1, 1)
aryFinal(2, 1) = NewFary(2, 1)
aryFinal(3, 1) = NewFary(3, 1)
For i = 1 To UBound(NewFary, 2)
      myJudge = True
      For j = 1 To UBound(aryFinal, 2)
          If NewFary(3, i) = aryFinal(3, j) Then
             myJudge = False '같으므로 뺀다
          End If
      Next j
      If myJudge = True Then
         ReDim Preserve aryFinal(3, UBound(aryFinal, 2) + 1)
         aryFinal(1, UBound(aryFinal, 2)) = NewFary(1, i)
         aryFinal(2, UBound(aryFinal, 2)) = NewFary(2, i)
         aryFinal(3, UBound(aryFinal, 2)) = NewFary(3, i)
       End If
Next i
'앞번호 다시 매기기
For i = 1 To UBound(aryFinal, 2)
      aryFinal(1, i) = i
Next i
Extract_EachName = WorksheetFunction.Transpose(aryFinal)
'If k <> 1 Then MsgBox "중복된 항목이 " & vbCr _
                     & k - 1 & "개가 있어 그항목은 추가하지 않았습니다.", _
                     vbInformation, "만득"
End Function

Function Extract_EachName_2(Myary)
Application.Volatile (True)
Dim i As Integer
Dim j As Integer
Dim NewFary
Dim aryFinal()
Dim myJudge As Boolean
Dim k As Byte
NewFary = Myary
ReDim aryFinal(4, 1)
aryFinal(1, 1) = NewFary(1, 1)
aryFinal(2, 1) = NewFary(2, 1)
aryFinal(3, 1) = NewFary(3, 1)
aryFinal(4, 1) = NewFary(4, 1)
For i = 1 To UBound(NewFary, 2)
      myJudge = True
      For j = 1 To UBound(aryFinal, 2)
          If NewFary(1, i) = aryFinal(1, j) Then
             myJudge = False '같으므로 뺀다
            'k = k + 1
          End If
      Next j
      If myJudge = True Then
         ReDim Preserve aryFinal(4, UBound(aryFinal, 2) + 1)
         aryFinal(1, UBound(aryFinal, 2)) = NewFary(1, i)
         aryFinal(2, UBound(aryFinal, 2)) = NewFary(2, i)
         aryFinal(3, UBound(aryFinal, 2)) = NewFary(3, i)
         aryFinal(4, UBound(aryFinal, 2)) = NewFary(4, i)
       End If
Next i
Extract_EachName_2 = aryFinal
End Function

Function ColorName(i As Integer) As String
Application.Volatile
Dim cName As String
Select Case i
         Case 1: cName = "검정":       Case 2: cName = "흰색"
         Case 3: cName = "빨강":       Case 4: cName = "밝은녹색"
         Case 5: cName = "파랑":       Case 6: cName = "노랑"
         Case 7: cName = "분홍":       Case 8: cName = "밝은옥색"
         Case 9: cName = "진한빨강":   Case 10: cName = "녹색"
         Case 11: cName = "진한파랑": Case 12: cName = "진한노랑"
         Case 13: cName = "보라":      Case 14: cName = "진한청록"
         Case 15: cName = "회색25%":   Case 16: cName = "회색50%"
         Case 17: cName = "빙카색":    Case 18: cName = "자주색"
         Case 19: cName = "상아색":    Case 20: cName = "연한옥색"
         Case 21: cName = "진한자주": Case 22: cName = "산호색"
         Case 23: cName = "바다색":    Case 24: cName = "담청색"
         Case 25: cName = "진한파랑": Case 26: cName = "분홍"
         Case 27: cName = "노랑":      Case 28: cName = "밝은옥색"
         Case 29: cName = "보라":      Case 30: cName = "진한빨강"
         Case 31: cName = "진한청록": Case 32: cName = "파랑"
         Case 33: cName = "하늘색":    Case 34: cName = "연한옥색"
         Case 35: cName = "연녹색":    Case 36: cName = "연노랑"
         Case 37: cName = "흐린파랑": Case 38: cName = "장미색"
         Case 39: cName = "연보라":    Case 40: cName = "살색"
         Case 41: cName = "연한파랑": Case 42: cName = "연한녹청"
         Case 43: cName = "라임":      Case 44: cName = "금색"
         Case 45: cName = "연한주황": Case 46: cName = "주황"
         Case 47: cName = "청회색":    Case 48: cName = "회색40%"
         Case 49: cName = "진한옥색": Case 50: cName = "해록색"
         Case 51: cName = "진한녹색": Case 52: cName = "황록색"
         Case 53: cName = "갈색":      Case 54: cName = "자주"
         Case 55: cName = "남색":      Case 56: cName = "회색80%"
         Case -4142: cName = "무색"
End Select
ColorName = cName
End Function

Function CB_Color_Select(DecColor)
Select Case DecColor
         Case &H0&                     '11
               DecColor = 1
         Case &H80&                    '21
               DecColor = 9
         Case &HFF&                    '31
               DecColor = 3
         Case &HFF00FF                 '41
               DecColor = 7
         Case &HFFC0FF                 '51
               DecColor = 38
         Case &H4080&                  '12
               DecColor = 53
         Case &H40C0&                  '22
               DecColor = 46
         Case &H80FF&                  '32
               DecColor = 45
         Case &HFFFF&                  '42
               DecColor = 44
         Case &HC0E0FF                 '52
               DecColor = 40
         Case &H4040&                  '13
               DecColor = 52
         Case &H8080&                  '23
               DecColor = 12
         Case &H80FF80                 '33
               DecColor = 43
         Case &H80FFFF                 '43
               DecColor = 6
         Case &HC0FFFF                 '53
               DecColor = 36
         Case &H4000&                  '14
               DecColor = 51
         Case &H8000&                  '24
               DecColor = 10
         Case &HC000&                  '34
               DecColor = 50
         Case &HFF00&                  '44
               DecColor = 4
         Case &HC0FFC0                 '54
               DecColor = 35
         Case &H404000                 '15
               DecColor = 49
         Case &H808000                 '25
               DecColor = 14
         Case &HC0C000                 '35
               DecColor = 42
         Case &HFFFF80                 '45
               DecColor = 8
         Case &HFFFFC0                 '55
               DecColor = 34
         Case &H800000                 '16
               DecColor = 11
         Case &HC00000                 '26
               DecColor = 5
         Case &HFF0000                 '36
               DecColor = 41
         Case &HFFFF00                 '46
               DecColor = 33
         Case &HFFC0C0                 '56
               DecColor = 37
         Case &H400000                 '17
               DecColor = 55
         Case &HFF8080                 '27
               DecColor = 47
         Case &H400040                 '37
               DecColor = 13
         Case &H800080                 '47
               DecColor = 54
         Case &HC000C0                 '57
               DecColor = 39
         Case &H404040                 '18
               DecColor = 56
         Case &H808080                 '28
               DecColor = 16
         Case &HC0C0C0                 '38
               DecColor = 48
         Case &HE0E0E0                 '48
               DecColor = 15
         Case &HFFFFFF                 '58
               DecColor = 2
         Case &H8000000B               '68
               DecColor = -4142
End Select
CB_Color_Select = DecColor
End Function

Function NewText(sTemp As String)
'주어진 문자열에 대해 OLD TEXT를 NEW TEXT로 교체
sTemp = Replace(sTemp, "A", "Ａ"): sTemp = Replace(sTemp, "a", "ａ")
sTemp = Replace(sTemp, "B", "Ｂ"): sTemp = Replace(sTemp, "b", "ｂ")
sTemp = Replace(sTemp, "C", "Ｃ"): sTemp = Replace(sTemp, "c", "ｃ")
sTemp = Replace(sTemp, "D", "Ｄ"): sTemp = Replace(sTemp, "d", "ｄ")
sTemp = Replace(sTemp, "E", "Ｅ"): sTemp = Replace(sTemp, "e", "ｅ")
sTemp = Replace(sTemp, "F", "Ｆ"): sTemp = Replace(sTemp, "f", "ｆ")
sTemp = Replace(sTemp, "G", "Ｇ"): sTemp = Replace(sTemp, "g", "ｇ")
sTemp = Replace(sTemp, "H", "Ｈ"): sTemp = Replace(sTemp, "h", "ｈ")
sTemp = Replace(sTemp, "I", "Ｉ"): sTemp = Replace(sTemp, "i", "ｉ")
sTemp = Replace(sTemp, "J", "Ｊ"): sTemp = Replace(sTemp, "j", "ｊ")
sTemp = Replace(sTemp, "K", "Ｋ"): sTemp = Replace(sTemp, "k", "ｋ")
sTemp = Replace(sTemp, "L", "Ｌ"): sTemp = Replace(sTemp, "l", "ｌ")
sTemp = Replace(sTemp, "M", "Ｍ"): sTemp = Replace(sTemp, "m", "ｍ")
sTemp = Replace(sTemp, "N", "Ｎ"): sTemp = Replace(sTemp, "n", "ｎ")
sTemp = Replace(sTemp, "O", "Ｏ"): sTemp = Replace(sTemp, "o", "ｏ")
sTemp = Replace(sTemp, "P", "Ｐ"): sTemp = Replace(sTemp, "p", "ｐ")
sTemp = Replace(sTemp, "Q", "Ｑ"): sTemp = Replace(sTemp, "q", "ｑ")
sTemp = Replace(sTemp, "R", "Ｒ"): sTemp = Replace(sTemp, "r", "ｒ")
sTemp = Replace(sTemp, "S", "Ｓ"): sTemp = Replace(sTemp, "s", "ｓ")
sTemp = Replace(sTemp, "T", "Ｔ"): sTemp = Replace(sTemp, "t", "ｔ")
sTemp = Replace(sTemp, "U", "Ｕ"): sTemp = Replace(sTemp, "u", "ｕ")
sTemp = Replace(sTemp, "V", "Ｖ"): sTemp = Replace(sTemp, "v", "ｖ")
sTemp = Replace(sTemp, "W", "Ｗ"): sTemp = Replace(sTemp, "w", "ｗ")
sTemp = Replace(sTemp, "X", "Ｘ"): sTemp = Replace(sTemp, "x", "ｘ")
sTemp = Replace(sTemp, "Y", "Ｙ"): sTemp = Replace(sTemp, "y", "ｙ")
sTemp = Replace(sTemp, "Z", "Ｚ"): sTemp = Replace(sTemp, "z", "ｚ")
sTemp = Replace(sTemp, 0, "０")
sTemp = Replace(sTemp, 1, "１")
sTemp = Replace(sTemp, 2, "２")
sTemp = Replace(sTemp, 3, "３")
sTemp = Replace(sTemp, 4, "４")
sTemp = Replace(sTemp, 5, "５")
sTemp = Replace(sTemp, 6, "６")
sTemp = Replace(sTemp, 7, "７")
sTemp = Replace(sTemp, 8, "８")
sTemp = Replace(sTemp, 9, "９")
sTemp = Replace(sTemp, "(", "（")
sTemp = Replace(sTemp, ")", "）")
sTemp = Replace(sTemp, "_", "＿")
sTemp = Replace(sTemp, "-", "－")
sTemp = Replace(sTemp, ".", "．")
sTemp = Replace(sTemp, ",", "，")
sTemp = Replace(sTemp, " ", "　") '공백전각
NewText = sTemp
End Function

LIST

저작자표시 비영리 변경금지 (새창열림)

'내역관련 > 함수' 카테고리의 다른 글

vlookup의 활용(Ⅰ), 아파트 관리비 청구서 (0)	2022.10.07
sumif의 활용 (금전출납부) (1)	2022.10.07
진수변환(사용자정의 함수) (1)	2022.10.07
내컴퓨터에 연결된 프린터 포트 찾기 함수 (0)	2022.10.07
SUMPRODUCT의 활용 (배열함수의 이해) (1)	2022.10.06

현재글기타 사용자정의 함수

EXcelToolBox