VB용 Excel Report 일부모음

VB, VBA, Win32, ExcelReport 전문 개발카페입니다. 많은 관심 부탁드리여~~^^

http://cafe.naver.com/xlsvba

걍 혹시 VB루 엑셀 리포트 하실일 생기시믄 사용하시믄 어떨가하고 올립니다..
쓰레기 자료일거 같아 좀 머뭇거리다가 올려봅니다...
제 레베루 잘 아시겠지만 신임도 50%두 안되는 소스이니 잘 수정하셔서 올려주시믄 잘 배껴쓰겟습니다....
일부 문제점이 잇을수 있을거 같기두 하궁...
최소 5개 이상의 Child폼에서 사용한다는 가정하에 Public으루 맨들었으니..
두서너군데에서  사용된다면 Class Module에 놓구 사용하심이 조을듯 싶습니다...

Option Explicit

Private Const PROCESS_TERMINATE = &H1&
Private Const SYNCHRONIZE = &H100000
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const Flags = SWP_NOMOVE Or SWP_NOSIZE
Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5

Private Declare Function GetTopWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal HProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId 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 ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function SearchTreeForFile Lib "imagehlp" (ByVal RootPath As String, ByVal InputPathName As String, ByVal OutputPathBuffer As String) As Long
Private Declare Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long

Public XlApp As Object
Public XlWb As Object
Public Const XL_NOTRUNNING As Long = 429
Public Const XPath As String = "RPT시험위원문서양식"



'======================================================================================
' Function Name : GetXhwnd
' DateTime      : 2007-03-13 17:34
' Author        : 서은아빠 (foxmotor@nate.com)
' Purpose       : 해당 Excel파일의 핸들값을 구한다.
' Param         : strFN - 해당파일의 확장자와 Path를 제외한 이름
' Return        : GetXhwnd - 해당 Excel파일의 핸들값
'======================================================================================
Public Function GetXhwnd(ByVal strFN As String) As Long
   
   On Error GoTo GetXhwnd_Error

       GetXhwnd = FindWindow("XLMAIN", "Microsoft Excel - " & strFN & ".xls")

   On Error GoTo 0
   
   Exit Function

GetXhwnd_Error:

   On Error GoTo 0
   MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetXhwnd of Module modExcel", , vbCritical
End Function


'============================================================================================
' Procedure     : Process_Kill
' Description   : API로 해당 엑셀프로세스 주겨버리기
' Author        : 서은아빠 (foxmotor@nate.com)
' Return        :
' Parameter     :strFN   : 저정한 엑셀윈도우의 캡션명(확장자를 제외한 파일명)
'============================================================================================
Public Sub Process_Kill(ByVal strFN As String)
Dim Chwnd      As Long
Dim HProcess  As Long
Dim PID           As Long
Dim TID           As Long

   On Error GoTo Process_Kill_Error

      Chwnd = GetXhwnd(strFN)
   
      TID = GetWindowThreadProcessId(Chwnd, PID)
   
      HProcess = OpenProcess(SYNCHRONIZE Or PROCESS_TERMINATE, 0&, PID)
   
      Call TerminateProcess(HProcess, 0&)
   
      Call CloseHandle(HProcess)

      On Error GoTo 0
       
      Exit Sub

Process_Kill_Error:

   On Error GoTo 0
   MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Process_Kill of Module modExcel", , vbCritical

End Sub



'======================================================================================
' Procedure : XReOpen
' DateTime  : 2007-03-13 17:46
' Author    : 서은아빠 (foxmotor@nate.com)
' Purpose   : 오픈된 엑셀을 재 오픈할시에 발생하는 오류를 사전에 차단
' Param     : strDpath - 해당파일의 FullName
'======================================================================================
Public Sub XReOpen(ByVal strDpath As String)
 Dim strFN As String
   On Error GoTo XReOpen_Error
       
       strFN = Mid(strDpath, InStrRev(strDpath, "", , vbTextCompare) + 1, _
       Len(strDpath) - InStrRev(strDpath, "", , vbTextCompare) - 4)

       If GetXhwnd(strFN) Then Call Process_Kill(strFN)
       
       Set XlApp = CreateObject("Excel.Application")
       
       With XlApp
           .WindowState = -4140        '## xlMinimized
           .Visible = True
           .EnableAnimations = False
           .workbooks.Open strDpath
       End With

   On Error GoTo 0
   
   Exit Sub

XReOpen_Error:

   On Error GoTo 0
   MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure XReOpen of Module modExcel", , vbCritical
End Sub




'======================================================================================
' Procedure : XlSetCreate
' DateTime  : 2007-03-13 17:46
' Author    : 서은아빠 (foxmotor@nate.com)
' Purpose   : 엑셀 개체를 생성하고 새로운 워크북을 만들고 시트의 개수를 생성한다.
' Param     : intSht - 생성 시트개수
'             bState - 윈도우 상태설정 True - xlMaximized, False - xlMinimized
'======================================================================================
Public Sub XlSetCreate(ByVal intSht As Integer, Optional bState As Boolean = False)
 Dim lngState As Long
 
   On Error GoTo XlSetCreate_Error

       Set XlApp = CreateObject("Excel.Application")
       
       lngState = IIf(bState = True, -4137, -4140)
       With XlApp
           .WindowState = lngState
           .Visible = True
           .EnableAnimations = False
           .SheetsInNewWorkbook = IIf(intSht > 0, intSht, 1)
           Set XlWb = .workbooks.Add

       End With
       
   On Error GoTo 0
   
   Exit Sub

XlSetCreate_Error:

   On Error GoTo 0
   MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure XlSetCreate of Module modExcel", , vbCritical
End Sub


'======================================================================================
' Procedure : XPreview
' DateTime  : 2007-03-13 17:58
' Author    : 서은아빠 (foxmotor@nate.com)
' Purpose   : Excel의 미리보기 창을 최상위 윈도우루 설정 - MDI폼을 BackGround루~~
' Param     : strFN - 해당파일의 확장자와 Path를 제외한 이름
'======================================================================================
Public Sub XPreview(ByVal strFN As String)
   
   On Error GoTo XPreview_Error

       SetWindowPos MDI폼.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, Flags
       
       SetWindowPos GetXhwnd(strFN), HWND_TOPMOST, 0, 0, 0, 0, Flags
       
       XlApp.WindowState = -4137
       
       XlApp.workbooks(strFN & ".xls").PrintPreview
       
       XlApp.WindowState = -4140
   
   Call Process_Kill(strFN)

   On Error GoTo 0
   
   Exit Sub

XPreview_Error:

   On Error GoTo 0
   MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure XPreview of Module modExcel", , vbCritical
   
End Sub


'======================================================================================
' Procedure : XHighPos
' DateTime  : 2007-03-13 17:52
' Author    : 서은아빠 (foxmotor@nate.com)
' Purpose   : Excel의 미리보기 창을 최상위 윈도우루 설정
'======================================================================================
Public Sub MDIHighPos(Optional BLK As Boolean = True)
 Dim Top As Long
   On Error GoTo MDIHighPos_Error
       Top = IIf(BLK = True, HWND_TOPMOST, HWND_NOTOPMOST)
       SetWindowPos KMPMAIN.hwnd, Top, 0, 0, 0, 0, Flags

   On Error GoTo 0
   
   Exit Sub

MDIHighPos_Error:

   On Error GoTo 0
   MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure MDIHighPos of Module modExcel", , vbCritical
End Sub

'======================================================================================
' Procedure : GetXlfile
' DateTime  : 2007-03-15 03:31
' Author    : 서은아빠 (foxmotor@nate.com)
' Purpose   : 프로세스가 살아있는 Excel파일을 ListUp
'======================================================================================
Public Sub GetXlfile(ByVal frmN As Form)
   Dim Xhwnd    As Long
   Dim lngRet   As Long
   Dim lngSpace As Long
   Dim strSpace As String
   Dim strXname As String
   Dim Buf      As String * 255
   
   frmN.Show vbModeless
   
   frmN.cbXl.Clear
   
   Xhwnd = GetTopWindow(0)   '### 바탕화면 다음 윈도우를 얻는다.
   
   Do
   
   Xhwnd = GetNextWindow(Xhwnd, GW_HWNDNEXT)   '### 바탕화면 다음 윈도우를 얻는다.
   
   strSpace = Space(128)                                 '### 적당한 공간 할당하구
   
   lngRet = GetClassName(Xhwnd, strSpace, 128)           '### 클래스명을 얻었다믄(lngRet<>0) 공터에다가 클래스명 처넣구
   
   If lngRet Then strSpace = Left(strSpace, lngRet)      '### 클래스명을 얻었다믄(lngRet<>0) 빈문자열 삭제하구선
   
   If strSpace = "XLMAIN" Then                           '### Excel 윈도우라면...
       
       lngSpace = GetWindowTextLength(Xhwnd)             '### 캡션 길이 구하구
       
       strXname = Space(lngSpace)                        '### 변수에 공간 할당
       
       Call GetWindowText(Xhwnd, strXname, lngSpace + 1) '### 숨기구나 보여주거나
       
       strXname = Mid(strXname, 19, Len(strXname)) ' & ".xls"
       
       frmN.cbXl.AddItem strXname
       
   End If                                                '### 아님 말구
   
   Loop While Xhwnd                                      '### 핸들값 존재하믄 계속 지루박 돌구
   
   frmN.cbXl.ListIndex = 0

End Sub 설문투표