살아가는 이야기

거의 대부분의 어플리케이션이 bom 포함한 파일을 사용하는데!!!

왜!!!!

Bom 없는 파일로 달라고 하는건지!!!!

뭐 설명은 뒤로 하고

Dim objStream As Object '오브젝트를 선언

strPathName ="C:\AAA.xml" '파일 위치와 이름

Set objStream = CreateObject("ADODB.Stream") '오브젝트 생성

objStream.Charset = "UTF-8" '캐릭터셋 설정

objStream.Open '열기!!

objStream.WriteText "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>" & vbCrLf 'xml 헤드에 쓰는건데 따옴표때문에 맨날 찾아서 붙여넣기 한다..ㅜ.ㅜ

objStream.WriteText "<AAA>" & vbCrLf '오브젝트에 글자쓰기!

Dim BinaryStream As Object '오브젝트를 선언

Set BinaryStream = CreateObject("adodb.stream")'오브젝트를 생성

BinaryStream.Type = 1 

BinaryStream.Mode = 3

BinaryStream.Open

objStream.Position = 3 '쓰기 위치

'Strips BOM (붐없애기)

objStream.CopyTo BinaryStream ' 오브젝트스트림 내용을 바이너리스트림으로 복사

objStream.Flush 

objStream.Close '오브젝트스트림 잘가~

BinaryStream.SaveToFile strPathName, 2 '저장

BinaryStream.Close '바이너리스트림도 할꺼 다했으니 잘강~

에 그러니까 objStream에 글자 쓸꺼 다 쓰고 

붐을 제외한 것을 BinaryStream 에 카피 해서 쓰는 방식

와 겁니 해메였구나~

매크로 하다보면 작업자마다

폴더위치가 괴상망칙해지는 경우가 많아 파일하나에 위치를 지정했더니

각자 파일을 써야 되는 문제 발생

레지스트리에 써버리자...

Sub setxmlfolder() '함수이름 

Set wsh2 = CreateObject("WScript.Shell") '스크립트 쉘 하나 생성

On Error Resume Next

strRegValue2 = wsh.RegRead(strRegPath2) '해당 패스의 값을 읽어

If GetSetting(appname:="Exportxml", section:="folder", Key:="xmlfolder", Default:="0") <> 0 Then 'Err.Number <> 0 Then

'값 읽어오기 기본 패스는 "HKEY_CURRENT_USER\Software\VB and VBA Program Settings 하위에 Exportxml <- app name , folder<-section , xmlfolder <-key 

    If msgValue = 1 Then

'폴더위치 설정

        With Application.FileDialog(msoFileDialogFolderPicker) 

            .InitialFileName = Application.DefaultFilePath & "\"

            .Title = "변경위치를 설정해주세요"

            .Show

            If .SelectedItems.Count = 0 Then

                MsgBox "xml 익스포트 위치 설정 취소"

                ExitAll = True

            Else

                SaveSetting appname:="Exportxml", section:="folder", Key:="xmlfolder", setting:=.SelectedItems(1)

'폴더위치 저장

                MsgBox ("xml위치" & GetSetting(appname:="Exportxml", section:="folder", Key:="xmlfolder", Default:="25") & " 로 설정되었습니다")

                ExitAll = False

            End If

        End With

    Else: MsgBox "설정취소됨"

    ExitAll = True

    End If

Else

msgValue = MsgBox("익스포트 위치가 없습니다. 설정해주세요" & vbCr & "취소하면 익스포트 안됩니다.", vbOKCancel)

    If msgValue = 1 Then

        With Application.FileDialog(msoFileDialogFolderPicker)

            .InitialFileName = Application.DefaultFilePath & "\"

            .Title = "xml 위치가 없습니다 설정해주세요. 기본위치는 \dev\Config\APP\ 입니다"

            .Show

            If .SelectedItems.Count = 0 Then

                MsgBox "xml 익스포트 위치 설정 취소"

                ExitAll = True

            Else

                SaveSetting appname:="Exportxml", section:="folder", Key:="xmlfolder", setting:=.SelectedItems(1)

                MsgBox ("xml위치" & GetSetting(appname:="Exportxml", section:="folder", Key:="xmlfolder", Default:="25") & " 로 설정되었습니다")

                ExitAll = False

            End If

        End With

    Else: MsgBox "설정취소됨"

    ExitAll = True

    End If

End If

End Sub

음.....잘되네...뭐지...ㅋㅋㅋㅋ

http://tone.tistory.com/93(VBA 다른 엑셀파일에 있는 셀값 가져오기)

있는 다른 엑셀파일을 열지 않고 가져오는 방식의 경우

많은 정보를 가져오려면 파일IO 를 이용하기 때문에 더럽게 느린 현상이 발생

그래서 이번에는 다른파일이 있다면 열어서 가져오자!

대상파일 : EffectTable.xlsm

작업  : 대상파일에 있는 DirectorKey,ActionDirectorKey,GetHitDirectorKey,GetHitObjectEffect 를

원본파일에 넣기

Private Sub CommandButton1_Click()

strpath = ThisWorkbook.Path

Path = Left(strpath, InStrRev(strpath, "\") - 1)

file = ThisWorkbook.Name

Filename = Left(file, InStrRev(file, ".") - 1)

strPathName = Path & "\" & Filename & ".txt"

strSheetName = ActiveSheet.Name

For n1 = 1 To 200

If Cells(12, n1).Interior.ColorIndex <> -4142 Then

col = col + 1

End If

Next n1

With Application                                                    '엑셀에서

.ScreenUpdating = False                                  '화면 업데이트 (일시)정지

.Calculation = xlCalculationManual                    '셀계산 수동으로 전환

End With

Dim objStream As Object '오브젝트를 선언

Set objStream = CreateObject("ADODB.Stream") '오브젝트 생성

objStream.Open '열기!!

objStream.Position = 0 '쓰기 위치

objStream.Charset = "euc-kr" '캐릭터셋 설정

ClientPath = Left(strpath, InStrRev(strpath, "\") - 1)

aa = "TortoiseProc.exe /command:update /path:"

aa = aa + """" + ClientPath + """" + " /closeonend:2"

Shell (aa)

strFile2 = "EffectTable.xlsm"

Dim rngB As Workbook

Dim bName As String

bName = strFile2

For Each rngB In Workbooks

    If rngB.Name = bName Then

        MsgBox bName & "문서가 열려있군요!" & Chr(10) & Chr(10) & "닫겠슴니당"

         Workbooks(bName).Close savechanges:=False '파일을 닫고

    End If

Next rngB

Workbooks.Open Filename:=strpath & "\EffectTable.xlsm"

Windows("SkillTable.xlsm").Activate

For n1 = 1 To col - 1                                   '해당하는 칼럼번호 저장

    If Cells(13, n1).Value = "DirectorKey" Then

            DirectorKey = n1

        ElseIf Cells(13, n1).Value = "ActionDirectorKey" Then

            ActionDirectorKey = n1

        ElseIf Cells(13, n1).Value = "GetHitDirectorKey" Then

            GetHitDirectorKey = n1

        ElseIf Cells(13, n1).Value = "GetHitObjectEffect" Then

            GetHitObjectEffect = n1

    End If

Next n1

For n = 15 To WorksheetFunction.CountA(Worksheets(strSheetName).Columns(1))   

For xx = 13 To Workbooks("EffectTable.xlsm").Sheets("이펙트").Cells(1, 10)

    If Cells(n, 1).Value = Workbooks("EffectTable.xlsm").Sheets("이펙트").Cells(xx, 1) Then   

'인덱스가 같은걸 확인

    Cells(n, DirectorKey).Value = Workbooks("EffectTable.xlsm").Sheets("이펙트").Cells(xx, 2)

    Cells(n, ActionDirectorKey).Value = Workbooks("EffectTable.xlsm").Sheets("이펙트").Cells(xx, 3)

    Cells(n, GetHitDirectorKey).Value = Workbooks("EffectTable.xlsm").Sheets("이펙트").Cells(xx, 4)

    Cells(n, GetHitObjectEffect).Value = Workbooks("EffectTable.xlsm").Sheets("이펙트").Cells(xx, 5)

        Exit For

    End If

Next xx

Next n

For n = 1 To WorksheetFunction.CountA(Worksheets(strSheetName).Columns(1))

For n1 = 1 To col - 1

If Cells(n, n1).Value <> "" Then

    If Cells(n, n1).Value = "True" Then

        Text = Text & "TRUE" & vbTab

        ElseIf Cells(n, n1).Value = "False" Then

            Text = Text & "FALSE" & vbTab

        Else: Text = Text & Cells(n, n1).Value & vbTab

    End If

    Else: Text = Text & vbTab

End If

Next n1

objStream.WriteText Text & vbCrLf

Text = ""

Next n

objStream.SaveToFile strPathName, 2 'strPathName 에 파일 위치와 파일명이 있어야함

objStream.Close '닫기

    With Application                                                    '엑셀에서

    .Calculation = xlCalculationAutomatic                    '셀계산 자동으로 전환

    .ScreenUpdating = True

    End With

For Each rngB In Workbooks

    If rngB.Name = bName Then

         Workbooks(bName).Close savechanges:=False '파일을 닫고

    End If

Next rngB

MsgBox "TXT 저장완료"

End Sub

일하다 보면 실제 작업서버와 외부서버간의 데이터를 맞추게 될일이 많다.
근데 이걸 svn 익스포트로 하려니 졸랭 귀찮아..-_-
그래서 배치 파일 하나 만듬

Ex) 1서버 폴더에 있는 작업물을 2서버폴더와 3서버폴더에 동일하게 적용하기

@echo off
TortoiseProc.exe /command:update /path:"C:\1서버폴더\Script" /closeonend:2
TortoiseProc.exe /command:update /path:"C:\2서버폴더\Script" /closeonend:2
TortoiseProc.exe /command:update /path:"C:\3서버폴더\Script" /closeonend:2
xcopy "D:\Server\DesignServer\Script" "C:\2서버폴더\Script" /s /i /y
xcopy "D:\Server\DesignServer\Script" "C:\3서버폴더\Script" /s /i /y
TortoiseProc.exe /command:commit /path:"C:\2서버폴더\Script" /closeonend:2
TortoiseProc.exe /command:commit /path:"C:\3서버폴더\Script" /closeonend:2

흠 근데 이렇게 했더니 승질나게 지워진 파일은 적용이 안되는 문제가 발생
그래서 지우는 명령 추가

@echo off
TortoiseProc.exe /command:update /path:"C:\1서버폴더\Script" /closeonend:2
TortoiseProc.exe /command:update /path:"C:\2서버폴더\Script" /closeonend:2
TortoiseProc.exe /command:update /path:"C:\3서버폴더\Script" /closeonend:2
del /s/q "C:\2서버폴더\Script\*"
del /s/q "C:\3서버폴더\Script\*"
xcopy "D:\Server\DesignServer\Script" "C:\2서버폴더\Script" /s /i /y
xcopy "D:\Server\DesignServer\Script" "C:\3서버폴더\Script" /s /i /y
TortoiseProc.exe /command:commit /path:"C:\2서버폴더\Script" /closeonend:2
TortoiseProc.exe /command:commit /path:"C:\3서버폴더\Script" /closeonend:2

아 정말 닭이네..쓰는것만 하고 읽는거 포스팅 안함..(아놕)

다른애들과 동일하게 VBA 메뉴 도구-참고에서

위에 체크한거 다해야함 안하면 안뎀

    Dim objStream As Object '선언
    Set objStream = CreateObject("ADODB.Stream") '만들기
   
    Dim var_String As Variant '졸라지게 큰 스트링 배정
    objStream.Charset = "UTF-8" '읽어옭 캐릭터셋 지정
    objStream.Open '파일열어!!
    objStream.LoadFromFile ClientPath & Application.PathSeparator & "파일명"
    var_String = Split(objStream.ReadText, vbCrLf) 'split entire file into array - lines delimited by CRLF '에 그러니까 CRLF  줄넘김 있으면 자르는거임
    Range("i1").Resize(UBound(var_String) - LBound(var_String)).Value = Application.Transpose(var_String)'i1 부터 넣음

'요기서 부터는 셀 자르기!!

    Worksheets(strSheetName).Cells(1, 8) = "=COUNTA(i:i)"
    For j = 3 To Worksheets(strSheetName).Cells(1, 8) - 1
        strData = Worksheets(strSheetName).Cells(j, 9)
        upst = 1 '이거 맨앞에 어퍼스트로피(') 요놈이 있는경우가 있어서 체크함
        For i = 1 To Len(strData)
            strText = Mid(strData, i, 1)
            If strText = ">" Or strText = "<" Or i = Len(strData) Or strText = """" Then
                If Mid(strTemp, 1, 1) = "'" Then
                rngImport.Offset(r, c) = "''" + strTemp
                Else
                rngImport.Offset(r, c) = strTemp
                End If
                c = c + 1
                strTemp = ""
            Else
                If strText <> Chr(34) Then
                       strTemp = strTemp & strText
                End If
            End If
        Next i
        c = 0
        r = r + 1
    Next j

xml로 열심히 작업해놨는데
운영툴 제작으로 인하여 엑셀에서 직접 DB 로 데이터 넣는 작업을 하게 되었음...

아...귀찮아

다시 구글링~~

vba 메뉴에서 도구-참조 에서 위에꺼 다 설정 //예전에 한거라 뭐였는지 기억이 안남..-_-

Dim a() '필드명 넣을넘
Dim b() '데이터 넣을넘
Dim DbCon As New ADODB.Connection '커넥션 관련 지정
strConnect = "Provider=SQLOLEDB.1; Persist Security Info=True; User ID=아이디; Password=패스워드; Initial Catalog=데이터베이스이름; Data Source=아이피" '연결 명령어를 스트링으로 저장
DbCon.Open strConnect '디비랑 연결~~
strSQL = "DELETE from 테이블명 '기존에 있던 테이블 데이터 지우기
DbCon.Execute strSQL '실행

'strSQL = "INSERT INTO 테이블명" & Filename & " values(" & k2 & ")"
'DbCon.Execute strSQL
'DbCon.Close             ' 디비닫기
'Set DbCon = Nothing     ' 개체반환

'여기서부터는 뭐 참고로 생각하시면됨
nRow = WorksheetFunction.CountA(Worksheets(strSheetName).Rows(1))
cn = 0
For j = 1 To nRow '서버에 올릴 필드 개수 체크
If Worksheets(strSheetName).Cells(1, j).Font.ColorIndex = 2 Then
    cn = cn + 1
End If
Next j
ReDim a(cn - 1)
ReDim b(cn - 1)
fl = -1
For j = 1 To nRow '필드명을 배열에 저장
If Worksheets(strSheetName).Cells(1, j).Font.ColorIndex = 2 Then
   fl = fl + 1
    a(fl) = Worksheets(strSheetName).Cells(1, j).Value
End If
Next j
For j = 0 To fl '배열에 저장된 필드명을 k3에 나열
    If j = fl Then
        k3 = k3 & "," & a(j)
    ElseIf j = 0 Then
    k3 = k3 & a(j)
    Else: k3 = k3 & "," & a(j)
    End If
Next j
nCol = WorksheetFunction.CountA(Worksheets(strSheetName).Columns(1))  ' 열의 갯수 체크

For k = 2 To nCol
ii = -1
    For j = 1 To nRow
        If Worksheets(strSheetName).Cells(1, j).Font.ColorIndex = 2 Then
                ii = ii + 1
                b(ii) = Worksheets(strSheetName).Cells(k, j)
        End If
    Next j
    For jj = 0 To fl '배열에 저장된 값을 k2에 나열
        If jj = fl Then
            k2 = k2 & ",'" & b(jj) & "'"
        ElseIf jj = 0 Then
        k2 = k2 & "'" & b(jj) & "'"
        Else: k2 = k2 & ",'" & b(jj) & "'"
        End If
    Next jj
strSQL = "INSERT INTO 테이블명" & Filename & " values(" & k2 & ")"
DbCon.Execute strSQL
Er_Rtn:
      If Err <> 0 Then
          MsgBox Err.Description & vbCrLf & strSheetName & " 시트의" & k & "행 값을 확인하세요"
          Exit Sub
      End If
k2 = ""
Next k
DbCon.Close             ' 디비닫기
Set DbCon = Nothing     ' 개체반환

해외버전 작업시 UTF-8로 스트링 파일을 저장해야 하는 문제가 발생

기존의 파일 쓰기 방식으로는 파일 생성시 캐릭터 셋이 ansi 로 되기 때문에 구글링~~~

vba 도구 참조에서 

Dim objStream As Object '오브젝트를 선언
Set objStream = CreateObject("ADODB.Stream") '오브젝트 생성
objStream.Open '열기!!
objStream.Position = 0 '쓰기 위치
objStream.Charset = "UTF-8" '캐릭터셋 설정
objStream.WriteText "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>" & vbCrLf
'쓰기 vbCrLf 는 줄바꿈 명령어
objStream.SaveToFile strPathName, 2 'strPathName 에 파일 위치와 파일명이 있어야함
objStream.Close '닫기
Set objStream = Nothing '사라져!!

Private Declare Function EnumProcesses Lib "PSAPI.DLL" ( _
   lpidProcess As Long, ByVal cb As Long, cbNeeded As Long) As Long

Private Declare Function OpenProcess Lib "kernel32" ( _
    ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
   
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long) As Long

Private Declare Function EnumProcessModules Lib "PSAPI.DLL" ( _
    ByVal hProcess As Long, lphModule As Long, ByVal cb As Long, lpcbNeeded As Long) As Long

Private Declare Function GetModuleBaseName Lib "PSAPI.DLL" Alias "GetModuleBaseNameA" ( _
    ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long

Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Function IsProcessRunning(ByVal sProcess As String) As Boolean
    Const MAX_PATH As Long = 260
    Dim lProcesses() As Long, lModules() As Long, N As Long, lRet As Long, hProcess As Long
    Dim sName As String
   
    sProcess = UCase$(sProcess)
   
    ReDim lProcesses(1023) As Long
    If EnumProcesses(lProcesses(0), 1024 * 4, lRet) Then
        For N = 0 To (lRet \ 4) - 1
            hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lProcesses(N))
            If hProcess Then
                ReDim lModules(1023)
                If EnumProcessModules(hProcess, lModules(0), 1024 * 4, lRet) Then
                    sName = String$(MAX_PATH, vbNullChar)
                    GetModuleBaseName hProcess, lModules(0), sName, MAX_PATH
                    sName = Left$(sName, InStr(sName, vbNullChar) - 1)
                    If Len(sName) = Len(sProcess) Then
                        If sProcess = UCase$(sName) Then IsProcessRunning = True: Exit Function
                    End If
                End If
            End If
            CloseHandle hProcess
        Next N
    End If
End Function

mainsub()
    Do
    Loop While (IsProcessRunning("TortoiseProc.exe")) = True
endsub

왜 내가 이걸 하고 있을까 하는 의문이 들었다..-_-