유니티 프로젝트를 진행하며 엑셀 데이터를 바이너리로 만들어야 하는 경우가 발생
클라이언트 분이 만들어 주시긴 하지만
유니티 켜기가 싫다!!
만들자!!
Public Const strTitle = "noti" '박스 타이틀
Public Const msgCellsErr = " 셀에 오류가 있어 데이터 생성을 중단합니다."
Public Const msgNotDataSheet = "데이터 시트 테이블이 아니어서 프로세스를 종료합니다."
Option Explicit
' CodePage constant for UTF-8
Private Const CP_UTF8 = 65001
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (hpvDest As Any, _
hpvSource As Any, _
ByVal cbCopy As LongPtr)
'utf8 변환
Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpWideCharStr As LongPtr, _
ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As LongPtr, _
ByVal cbMultiByte As Long, _
ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long) As Long
Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpMultiByteStr As LongPtr, _
ByVal cchMultiByte As Long, _
ByVal lpWideCharStr As LongPtr, _
ByVal cchWideChar As Long _
) As Long
#Else
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'utf8 변환
Private Declare Function WideCharToMultiByte Lib "kernel32" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cbMultiByte As Long, _
ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long _
) As Long
#End If
'바이트로 변환을 위해 각 타입별로 바이트 변수 지정
Private Type ByteLong
value(3) As Byte
End Type
Private Type TypedLong
value As Long
End Type
Private Type ByteByte
value(0) As Byte
End Type
Private Type TypedByte
value As Byte
End Type
'타입별로 바이트 array 로 변환하는 펑션
Function LongToByteArray(ByVal value As Long) As Byte()
'Purpose: Converts a variable of the type Long to a byte array.
Dim tlJump As TypedLong
Dim blJump As ByteLong
tlJump.value = value
LSet blJump = tlJump
LongToByteArray = blJump.value
End Function
Function ByteToByteArray(ByVal value As Long) As Byte()
'Purpose: Converts a variable of the type Long to a byte array.
Dim tlJump As TypedByte
Dim blJump As ByteByte
tlJump.value = value
LSet blJump = tlJump
ByteToByteArray = blJump.value
End Function
Function SingToByte(ByVal D As Single) As Byte()
Dim Bytes(LenB(D) - 1) As Byte
Dim I As Integer
Dim S As String
CopyMemory Bytes(0), D, LenB(D)
For I = 0 To UBound(Bytes)
S = S & CStr(Bytes(I)) & " "
Next
SingToByte = Bytes
End Function
Sub bytes_export_Click(control As IRibbonControl) 'bytes Export 버튼 클릭시 실행될 내용
Call CDataD
End Sub
Sub bytes_Allexport_Click(control As IRibbonControl) 'All bytes Export 버튼 클릭시 실행될 내용
Dim sht As Worksheet
For Each sht In Worksheets
If sht.Name <> "info" Then
Call CreateData(sht.Name, 1)
End If
Next sht
MsgBox ThisWorkbook.Path & "\" & "bytes" & "\" & Chr(10) & "데이터 익스포트 완료", Title:=strTitle
End Sub
'어....어디서 가져왔더라...여튼 바이트를 utf8 변환하는 코드
'utf8 변환
Public Function Utf8BytesFromString(strInput As String) As Byte()
Dim nBytes As Long
Dim abBuffer() As Byte
' Catch empty or null input string
Utf8BytesFromString = vbNullString
If Len(strInput) < 1 Then Exit Function
' Get length in bytes *including* terminating null
nBytes = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(strInput), -1, 0&, 0&, 0&, 0&)
' We don't want the terminating null in our byte array, so ask for `nBytes-1` bytes
ReDim abBuffer(nBytes - 2) ' NB ReDim with one less byte than you need
nBytes = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(strInput), -1, ByVal VarPtr(abBuffer(0)), nBytes - 1, 0&, 0&)
Utf8BytesFromString = abBuffer
End Function
''' Return length of byte array or zero if uninitialized
'utf8 관련
Private Function BytesLength(abBytes() As Byte) As Long
' Trap error if array is uninitialized
On Error Resume Next
BytesLength = UBound(abBytes) - LBound(abBytes) + 1
End Function
''' Return VBA "Unicode" string from byte array encoded in UTF-8
Public Function Utf8BytesToString(abUtf8Array() As Byte) As String
Dim nBytes As Long
Dim nChars As Long
Dim strOut As String
Utf8BytesToString = ""
' Catch uninitialized input array
nBytes = BytesLength(abUtf8Array)
If nBytes <= 0 Then Exit Function
' Get number of characters in output string
nChars = MultiByteToWideChar(CP_UTF8, 0&, VarPtr(abUtf8Array(0)), nBytes, 0&, 0&)
' Dimension output buffer to receive string
strOut = String(nChars, 0)
nChars = MultiByteToWideChar(CP_UTF8, 0&, VarPtr(abUtf8Array(0)), nBytes, StrPtr(strOut), nChars)
Utf8BytesToString = Left$(strOut, nChars)
End Function
'중복키값체크
Sub checkDulpicatePrimarykey(str_SheetName As String)
On Error Resume Next
Dim int_CNT As Long
Dim int_Temp As Integer
Dim I, j As Integer
int_CNT = Application.CountA(Worksheets(str_SheetName).Range("A:A"))
Uf_status.Show
Uf_status.Caption = "PrimaryKey 중복 체크 중"
For I = 4 To int_CNT
'기본 키 비교
int_Temp = Application.CountIfs(Worksheets(str_SheetName).Range("A:A"), Worksheets(str_SheetName).Cells(I, 1) & "*", Worksheets(str_SheetName).Range("A:A"), Worksheets(str_SheetName).Cells(I, 1))
If int_Temp > 1 Then
MsgBox Worksheets(str_SheetName).Name & " 시트 " & I & " 열의 ID 가 중복됩니다." & Chr(10) & Chr(34) & Cells(I, 1) & Chr(34), Title:=strTitle
Unload Uf_status
Exit Sub
End If
Uf_status.lbl_status.Width = 210 / int_CNT * I
Uf_status.lbl_status_string = Int(I / int_CNT * 100) & " % " & "(" & I & "/" & int_CNT & ")"
Uf_status.Repaint
Next I
Unload Uf_status
End Sub
'헤더체크
Sub checkDulpicateHeader(str_SheetName As String) '헤더 중복 체크
Dim int_CNT As Long
Dim int_Temp As Integer
Dim I, j As Integer
Uf_status.Show
Uf_status.Caption = "필드명 중복 체크 중"
int_CNT = Application.CountA(ActiveSheet.Range("3:3"))
For I = 1 To int_CNT
'내부 사용을 위해 기울임꼴 처리된 항목 배제
If ActiveSheet.Cells(3, I).Font.FontStyle = "기울임꼴" Or ActiveSheet.Cells(3, I).Font.FontStyle = "굵은 기울임꼴" Then
Else
int_Temp = Application.CountIf(Range("3:3"), Cells(3, I))
If int_Temp > 1 Then
MsgBox Worksheets(str_SheetName).Name & " 시트 " & I & " 행의 이름이 중복됩니다." & Chr(10) & Chr(34) & Worksheets(str_SheetName).Cells(3, I) & Chr(34), Title:=strTitle
Unload Uf_status
Exit Sub
End If
Uf_status.lbl_status.Width = 210 / int_CNT * I
Uf_status.lbl_status_string = Int(I / int_CNT * 100) & " % " & "(" & I & "/" & int_CNT & ")"
Uf_status.Repaint
End If
Next I
Unload Uf_status
End Sub
실제 데이터 찍는곳
Sub CDataD()
Dim str_TempRng As String
'시트이름에 data_ 가 없으면 데이터 테이블 시트가 아닌 경우 종료
'If UCase(Left(ActiveSheet.Name, 5)) = "DATA_" Then
If ActiveSheet.Name <> "info" Then
str_TempRng = DetectErr(ActiveSheet.Name)
If str_TempRng <> "" Then
MsgBox str_TempRng & msgCellsErr, Title:=strTitle
GoTo Err
End If
'별도 프로시저를 호출
Call CreateData(ActiveSheet.Name, 0)
Exit Sub
Else
MsgBox msgNotDataSheet, Title:=strTitle
End If
Err:
End Sub
'에러 발생시 오류 메시지 출력
Function DetectErr(str_SName As String)
Dim rng_Temp As Object
On Error Resume Next
Set rng_Temp = Worksheets(str_SName).Cells.SpecialCells(xlCellTypeFormulas, 16)
If rng_Temp Is Nothing Then
Else
DetectErr = Worksheets(str_SName).Cells.SpecialCells(xlCellTypeFormulas, 16).Address
End If
Set rng_Temp = Worksheets(str_SName).Cells.SpecialCells(xlCellTypeConstants, 16)
If rng_Temp Is Nothing Then
Else
DetectErr = DetectErr + Worksheets(str_SName).Cells.SpecialCells(xlCellTypeConstants, 16).Address
End If
End Function
' 한글 완성형 문자열의 바이트 수 구하기 함수
Function LenMbcs(ByVal str As String)
LenMbcs = LenB(StrConv(str, vbFromUnicode))
End Function
'실제 시트 데이터 반복 부분
Sub CreateData(str_SheetName As String, ci As Integer)
Dim str_Path As String
Dim str_sSheetName As String
Dim byteName As String
Dim int_NFields As Integer
Dim int_NData, var_Tempindex As Long
Dim I, j As Long '셀 반복
Dim Body As Object
Dim var_TempType, var_TempValue
Dim var_TempLong As Long
Dim var_TempString As String
Dim var_Tempbyte() As Byte
Dim var_Tempbyte2 As Byte
Dim var_TempPrebyte() As Byte
Dim var_TempFloat As Single
Dim str_workPath As String
Dim ck_dir As Boolean
'중복키값 체크
Call checkDulpicatePrimarykey(str_SheetName)
Call checkDulpicateHeader(str_SheetName)
' 저장 폴더 존재 여부 체크 후 없다면 생성
If Dir("D:\work\DataTables\", vbDirectory) = "" Then
If Dir(ThisWorkbook.Path & "\" & "bytes" & "\", vbDirectory) = "" Then
MkDir ThisWorkbook.Path & "\" & "bytes" & "\"
ck_dir = False
End If
Else
ck_dir = True
End If
'시트 명으로 .bytes 파일명 지정, 안해도 되지만 프로그래머분이 이름을 다르게 쓰니 뭐...
If str_SheetName = "string_ui" Then
byteName = "StringUITable"
ElseIf str_SheetName = "weapon_info" Or str_SheetName = "fxList" Then
If str_SheetName = "weapon_info" Then byteName = "WeaponObj"
If str_SheetName = "fxList" Then byteName = "Effect"
byteName = byteName & "Table"
Else
byteName = UCase(Left(str_SheetName, 1))
If InStr(1, str_SheetName, "_") Then
' _ 있는 시트명 처리
byteName = byteName & Mid(str_SheetName, 2, InStr(1, str_SheetName, "_") - 2)
byteName = byteName & UCase(Mid(str_SheetName, InStr(1, str_SheetName, "_") + 1, 1)) _
& Mid(str_SheetName, InStr(1, str_SheetName, "_") + 2, Len(str_SheetName))
Else
'_ 없는 시트명 처리
byteName = UCase(Left(str_SheetName, 1)) & Mid(str_SheetName, 2, Len(str_SheetName))
End If
byteName = byteName & "Table"
End If
str_Path = ThisWorkbook.Path & "\" & "bytes" & "\" & byteName & ".bytes"
str_workPath = "D:\work\DataTables\" & byteName & ".bytes"
'이전파일이 있다면 삭제
If Dir(str_Path) <> vbNullString Then
Kill str_Path
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'.bytes 생성
Const adTypeBinary = 1
Const adSaveCreateOverWrite = 2
Set Body = CreateObject("ADODB.Stream")
Body.Type = 1
Body.Open
'sheet 의 사이즈를 확인하고
int_NFields = Application.CountA(Worksheets(str_SheetName).Range("1:1"))
int_NData = Application.CountA(Worksheets(str_SheetName).Range("a:a"))
'sheet 내용을 bytes 로 변환
' 'header 입력
' For j = 1 To int_NFields
'
' 'sheet 의 내용 중 데이터에 들어가지 않는 것 필터링, 글꼴이 기울임이면 제외
' If Worksheets(str_SheetName).Cells(3, j).Font.FontStyle = "기울임꼴" Or Worksheets(str_SheetName).Cells(3, j).Font.FontStyle = "굵은 기울임꼴" Then
' Else
' If str_Target = vbNullString Then
' str_Target = Worksheets(str_SheetName).Cells(3, j).value
' Else
' str_Target = str_Target & "," & Worksheets(str_SheetName).Cells(3, j).value
' End If
' End If
' Next j
'
' Body.WriteText = str_Target & Chr(10)
' str_Target = ""
Dim Ndata_c As Long
'키 개수 입력
Ndata_c = 0
For I = 4 To int_NData
If Worksheets(str_SheetName).Cells(I, 1).Font.FontStyle = "기울임꼴" Or Worksheets(str_SheetName).Cells(I, 1).Font.FontStyle = "굵은 기울임꼴" Then
Else
Ndata_c = Ndata_c + 1
End If
Next I
Body.Write LongToByteArray(Ndata_c)
'body 입력
For I = 4 To int_NData
If Worksheets(str_SheetName).Cells(I, 1).Font.FontStyle = "기울임꼴" Or Worksheets(str_SheetName).Cells(I, 1).Font.FontStyle = "굵은 기울임꼴" Then
'기본키 내용 중 기울임꼴인것 필터
Else
For j = 1 To int_NFields
If Worksheets(str_SheetName).Cells(3, j).Font.FontStyle = "기울임꼴" Or Worksheets(str_SheetName).Cells(3, j).Font.FontStyle = "굵은 기울임꼴" Then
'sheet 의 내용 중 데이터에 들어가지 않는 것 필터링
Else
'필드 내용 확인후 쓰기
var_TempType = UCase(Worksheets(str_SheetName).Cells(1, j).value)
var_TempValue = Worksheets(str_SheetName).Cells(I, j).value
If var_TempType = "INT" Then
'int 오버플로우 체크
If var_TempValue < -2147483648# Or var_TempValue > 2147483647 Then
If var_TempValue <> "" Then MsgBox Worksheets(str_SheetName).Name & " " & Worksheets(str_SheetName).Cells(I, j).Address & " 셀의 값(" & var_TempValue & ")이 범위를 넘었습니다(" & var_TempType & ").", Title:=strTitle
'int 타입일 때 "" value 에 대한 예외처리
Else
'int 타입일 때 처리
If str_SheetName = "monster_group" And j = int_NFields Then
var_TempLong = Worksheets(str_SheetName).Cells(I, j).value
Body.Write LongToByteArray(var_TempLong)
var_TempPrebyte = StrConv(Chr(255), vbFromUnicode)
Body.Write var_TempPrebyte
Body.Write var_TempPrebyte
Body.Write var_TempPrebyte
Body.Write var_TempPrebyte
Else
var_TempLong = Worksheets(str_SheetName).Cells(I, j).value
Body.Write LongToByteArray(var_TempLong)
End If
End If
ElseIf var_TempType = "BYTE" Then
'byte 오버플로우 체크
If var_TempValue < -1 Or var_TempValue > 256 Then
'byte 타입일 때 "" value 에 대한 예외처리
If var_TempValue <> "" Then MsgBox Worksheets(str_SheetName).Name & " " & Worksheets(str_SheetName).Cells(I, j).Address & " 셀의 값(" & var_TempValue & ")이 범위를 넘었습니다(" & var_TempType & ").", Title:=strTitle
Else
'byte 타입일 때 처리
var_Tempbyte2 = Worksheets(str_SheetName).Cells(I, j).value
Body.Write ByteToByteArray(var_Tempbyte2)
End If
ElseIf var_TempType = "STRING" Then
'string 인경우
' var_TempString = Chr(Len(Worksheets(str_SheetName).Cells(I, j).value)) + Worksheets(str_SheetName).Cells(I, j).value
' var_Tempbyte = StrConv(var_TempString, vbFromUnicode)
'utf8 변환
var_TempString = Worksheets(str_SheetName).Cells(I, j).value
var_Tempbyte = Utf8BytesFromString(var_TempString)
'var_TempPrebyte = StrConv(Chr(LenMbcs(Worksheets(str_SheetName).Cells(I, j).value)), vbFromUnicode)
var_TempPrebyte = StrConv(Chr(UBound(var_Tempbyte) - LBound(var_Tempbyte) + 1), vbFromUnicode)
Body.Write var_TempPrebyte
Body.Write var_Tempbyte
ElseIf var_TempType = "FLOAT" Then
'float 인경우
var_TempFloat = Worksheets(str_SheetName).Cells(I, j).value
var_Tempbyte = SingToByte(var_TempFloat)
Body.Write var_Tempbyte
End If
' '줄바꿈이 있거나, 콤마(,)가 있을 때 별도 처리
' If InStr(var_TempValue, Chr(10)) > 0 Or InStr(var_TempValue, ",") > 0 Then
'
' var_TempValue = """" & var_TempValue & """"
'
' End If
'
' If str_Target = vbNullString Then
' str_Target = var_TempValue
' Else
' str_Target = str_Target & "," & var_TempValue
'
' 'str_Target = str_Target & "," & Worksheets(str_SheetName).Cells(3, j).Value
'
' End If
End If
Next j
' Body.WriteText = str_Target & Chr(10)
' str_Target = ""
End If
Next I
If ck_dir Then
Body.savetofile str_workPath, adSaveCreateOverWrite
Else
Body.savetofile str_Path, adSaveCreateOverWrite
End If
Body.Close
If ci <> 1 And ck_dir Then
MsgBox str_workPath & Chr(10) & "데이터 익스포트 완료", Title:=strTitle
Else
MsgBox str_Path & Chr(10) & "데이터 익스포트 완료", Title:=strTitle
End If
End Sub
Sub xls_export_Click(control As IRibbonControl) 'xls Export 버튼 클릭시 실행될 내용
Call CreateXls
MsgBox ThisWorkbook.Path & "\" & "xls" & "\" & Chr(10) & "xls 생성완료", Title:=strTitle
End Sub
Sub CreateXls()
Dim sht As Worksheet
Dim str_Path As String '저장 파일명
Dim ob As Workbook '이전 워크북
Dim wb As Workbook '생성워크북
Dim str_SheetName As String
Dim int_NFields As Integer
Dim int_NData As Long
Dim var_TempType, var_TempValue
Dim I, j As Long '셀 반복
Set ob = Application.ActiveWorkbook
' 저장 폴더 존재 여부 체크 후 없다면 생성
If Dir(ob.Path & "\" & "xls" & "\", vbDirectory) = "" Then
MkDir ob.Path & "\" & "xls" & "\"
End If
'워크북 명으로로 .xls 파일명 지정
str_Path = ob.Path & "\" & "xls" & "\" & CreateObject("Scripting.FileSystemObject").GetBaseName(ob.Name) & "1.xlsx"
'이전파일이 있다면 삭제
If Dir(str_Path) <> vbNullString Then
Kill str_Path
End If
'파일생성
Set wb = Application.Workbooks.Add
For Each sht In ob.Worksheets
'If sht.Name <> "info" Then
str_SheetName = sht.Name
'중복키값 체크
Call checkDulpicatePrimarykey(str_SheetName)
Call checkDulpicateHeader(str_SheetName)
Sheets.Add
Sheets(1).Name = str_SheetName
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'sheet 복사
int_NFields = Application.CountA(ob.Worksheets(str_SheetName).Range("1:1"))
int_NData = Application.CountA(ob.Worksheets(str_SheetName).Range("a:a"))
For I = 1 To int_NData
If ob.Worksheets(str_SheetName).Cells(I, 1).Font.FontStyle = "기울임꼴" Or ob.Worksheets(str_SheetName).Cells(I, 1).Font.FontStyle = "굵은 기울임꼴" Then
'기본키 내용 중 기울임꼴인것 필터
Else
For j = 1 To int_NFields
If ob.Worksheets(str_SheetName).Cells(3, j).Font.FontStyle = "기울임꼴" Or ob.Worksheets(str_SheetName).Cells(3, j).Font.FontStyle = "굵은 기울임꼴" Then
'sheet 의 내용 중 데이터에 들어가지 않는 것 필터링
Else
'필드 내용 확인후 쓰기
var_TempType = UCase(ob.Worksheets(str_SheetName).Cells(1, j).value)
var_TempValue = ob.Worksheets(str_SheetName).Cells(I, j).value
If var_TempType = "INT" Then
'int 오버플로우 체크
If I >= 4 Then
If var_TempValue < -2147483648# Or var_TempValue > 2147483647 Then
If var_TempValue <> "" Then MsgBox ob.Worksheets(str_SheetName).Name & " " & ob.Worksheets(str_SheetName).Cells(I, j).Address & " 셀의 값(" & var_TempValue & ")이 범위를 넘었습니다(" & var_TempType & ").", Title:=strTitle
'int 타입일 때 "" value 에 대한 예외처리
Else
'int 타입일 때 처리
wb.Sheets(str_SheetName).Cells(I, j).value = ob.Worksheets(str_SheetName).Cells(I, j).value
End If
Else
wb.Sheets(str_SheetName).Cells(I, j).value = ob.Worksheets(str_SheetName).Cells(I, j).value
End If
ElseIf var_TempType = "STRING" Or var_TempType = "TXT" Then
'string 인경우
wb.Sheets(str_SheetName).Cells(I, j).value = ob.Worksheets(str_SheetName).Cells(I, j).value
ElseIf var_TempType = "FLOAT" Then
'float 오버플로우 체크
If I >= 4 Then
If var_TempValue < -2147483648# Or var_TempValue > 2147483647 Then
If var_TempValue <> "" Then MsgBox ob.Worksheets(str_SheetName).Name & " " & ob.Worksheets(str_SheetName).Cells(I, j).Address & " 셀의 값(" & var_TempValue & ")이 범위를 넘었습니다(" & var_TempType & ").", Title:=strTitle
'int 타입일 때 "" value 에 대한 예외처리
Else
wb.Sheets(str_SheetName).Cells(I, j).value = ob.Worksheets(str_SheetName).Cells(I, j).value
End If
Else
'float 일때 처리
wb.Sheets(str_SheetName).Cells(I, j).value = ob.Worksheets(str_SheetName).Cells(I, j).value
End If
End If
End If
Next j
End If
Next I
Next sht
'알림 메시지 비활성화
Application.DisplayAlerts = False
'자동 생성된 시트 1 삭제
wb.Sheets("sheet1").Delete
'알림 메시지 활성화
Application.DisplayAlerts = True
'저장
wb.SaveAs str_Path
wb.Close
MsgBox str_Path & Chr(10) & "데이터 익스포트 완료", Title:=strTitle
End Sub
음......괴랄해....
항상 느끼는 거지만 왜하고 있는거지...
랭크정리-복사본.xlsx