Module1辅助系统

Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpbuffer As String, ByVal nSize As Long) As Long
Private K3Login As Object '当前连接对象
Public cnStr As String
Public Rs1 As New ADODB.Recordset
Public SearchSql As String

Public Fitemid As Variant
Public FNumber As Variant
Public Fname As Variant
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long   '读写INI文件的API函数
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Public Public_cn As New ADODB.Connection
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Pub_DateName '账套名称
Public Const GWL_WNDPROC = (-4)
Public Pub_ZF_key2 As Integer
Public lpWndProc As Long

Public Pub_CustID_pass As String
Public Pub_Year_pass As String
Public Pub_Period_pass As String
Public Pub_LastMoney_pass As Single
Public Pub_RS_YL As New ADODB.Recordset '遗漏折让资料
Public Pub_Item_str As String
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long

Dim fso As New FileSystemObject


Private Const TH32CS_SNAPPROCESS = &H2
Private Const TH32CS_SNAPheaplist = &H1
Private Const TH32CS_SNAPthread = &H4
Private Const TH32CS_SNAPmodule = &H8
Private Const TH32CS_SNAPall = TH32CS_SNAPPROCESS + TH32CS_SNAPheaplist + TH32CS_SNAPthread + TH32CS_SNAPmodule
Private Const MAX_PATH As Integer = 260

Private Const PROCESS_ALL_ACCESS = &H100000 + &HF0000 + &HFFF

Private Type PROCESSENTRY32
dwSize As Long
cntUseage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
    pcPriClassBase As Long
swFlags As Long
szExeFile As String * 1024
End Type

Public pub_Change_key As Integer
Sub Main()

Dim userNameStr As String
Dim uesrNameTemp
Dim userName As String
Dim dateStr As String
Dim ServerStr As String
Dim jj As Integer
Dim str_upgrid As String
Dim Msg As Integer

Dim MySnapHandle As Long
Dim hProcess As Long
Dim ProcessInfo As PROCESSENTRY32
On Error GoTo HERROR
    If app.PrevInstance = True Then
       Msg = MsgBox("“金蝶K3辅助系统”正在运行，是否要重新登录？", vbOKCancel + vbInformation, "提示")
        If Msg = 1 Then
        Else
            End
        End If
    End If

    Set K3Login = CreateObject("K3Login.ClsLogin")
    If Not K3Login.CheckLogin Then
        Set K3Login = Nothing
        Exit Sub
    End If
    cnStr = Trim(K3Login.PropsString)
    userNameStr = cnStr
    
    Dim i As Long, j As Long
    i = InStr(1, cnStr, "{")
    j = InStr(1, cnStr, "}")
    cnStr = Left(cnStr, j - 1)
    cnStr = Right(cnStr, j - i - 1)
    SaveSetting app.EXEName, "Conn", "connstring", cnStr

    Set K3Login = Nothing
    cnStr = getLinkStr(cnStr)
    uesrNameTemp = Split(userNameStr, ";")
    For jj = 0 To UBound(uesrNameTemp)
        If Left(uesrNameTemp(jj), 9) = "UserName=" Then
            userName = Mid(uesrNameTemp(jj), 10)
            Exit For
        End If
    Next
    For jj = 0 To UBound(uesrNameTemp)
        If Left(uesrNameTemp(jj), 12) = "MachineName=" Then
            ServerStr = Mid(uesrNameTemp(jj), 13)
            Exit For
        End If
    Next
    For jj = 0 To UBound(uesrNameTemp)
        If Left(uesrNameTemp(jj), 16) = "Initial Catalog=" Then
            dateStr = Mid(uesrNameTemp(jj), 17)
            uesrNameTemp = Split(dateStr, "}")
            dateStr = uesrNameTemp(0)
            Exit For
        End If
    Next


  Set Public_cn = Nothing
   Public_cn.CursorLocation = adUseClient
   Public_cn.ConnectionString = cnStr
   Public_cn.Open
   
   Pub_UserName = userName

   Pub_Number = "2011-12-13"
   Set Rs1 = Nothing
   Rs1.Open "select FUserID, FName, FDescription, FForbidden,FDataVokeType  from t_User where FUserID in (select FUserID from t_Group where FGroupID = 1) and Fname='" & userName & "' and FUserID between 16384 and 32767", Public_cn
   If Rs1.RecordCount > 0 Then
     Pub_UserType = "adm"
   Else
    Pub_UserType = ""
   End If
    
    If pub_Change_key = 1 Then
'        Unload frm切换用户
'        Unload frm金蝶K3辅助系统
'        frm切换用户.Show
'        pub_Change_key = 0
    Else
        frm金蝶K3辅助系统.Show
    End If

    Exit Sub
HERROR:
    pub_Change_key = 0
    MsgBox Err.Description, vbInformation
End Sub
Public Function getLinkStr(OldString As String) As String
 getLinkStr = OldString
End Function


Public Sub Hook(hWnd As Long)
    lpWndProc = GetWindowLong(hWnd, GWL_WNDPROC)
    SetWindowLong hWnd, GWL_WNDPROC, AddressOf WindowProc
End Sub

Public Sub UnHook(hWnd As Long)

    SetWindowLong hWnd, GWL_WNDPROC, lpWndProc
End Sub

Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    
    If uMsg = WM_MOUSEWHEEL Then
    Dim wzDelta As Integer
    wzDelta = HIWORD(wParam)
    
    If Sgn(wzDelta) = 1 Then
    If TypeOf Screen.ActiveControl Is Grid Then Screen.ActiveControl.Scroll 0, -1
    Else
    If TypeOf Screen.ActiveControl Is Grid Then Screen.ActiveControl.Scroll 0, 1
    End If
    
    End If
    
    WindowProc = CallWindowProc(lpWndProc, hWnd, uMsg, wParam, lParam)

End Function

Public Function HIWORD(MsgParam As Long) As Integer
    HIWORD = (MsgParam And &HFFFF0000) \ &H10000
End Function

Public Sub YcExcel1(FCaption1 As String, FCaption2 As String, Grid As fpSpread, FileName As String)
    Dim StrFilename As String
    On Error GoTo AdoTOExcelErr
    'Dim xlapp As New Excel.Application
    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlWs As Object
    
    StrFilename = FileName
    If StrFilename = "" Then Exit Sub
    
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Add
    Set xlWs = xlWb.Worksheets("Sheet1")

    Screen.MousePointer = vbHourglass
    DoEvents
    
    Dim i As Long, j As Long
    
    DoEvents
    Dim StrJJJ As Variant
 
        xlWs.Cells.Clear
        
        'If ChkCovtChar.Value Then
        '    xlWs.Cells.Select
        '    xlApp.Selection.NumberFormatLocal = "@"
        'End If
        '********************导出标题
        iRow = 1: iCol = 1
        If FCaption1 <> "" Then xlWs.Cells(iRow, 1) = "'" & FCaption1 & "'": iRow = iRow + 1
        If FCaption2 <> "" Then xlWs.Cells(iRow, 1) = "'" & FCaption2 & "'": iRow = iRow + 1
        '*********************导出表头
''''''        For i = 0 To Grid.Cols - 1
''''''            If Grid.ColHidden(i) = False Then
''''''                xlWs.Cells(iRow, iCol) = Grid.TextMatrix(0, i)
''''''                iCol = iCol + 1
''''''            End If
''''''        Next i
''''''        iRow = iRow + 1
        
        '********************导出数据
        Grid.Row = SpreadHeader
        
        For i = 1 To Grid.MaxCols
            Grid.GetText i, SpreadHeader, FValue1
            Grid.Col = i
            If Grid.ColHidden = False Then
                xlWs.Cells(iRow, iCol) = FValue1
                iCol = iCol + 1
            End If
            
        Next i
        iRow = iRow + 1
        For i = 1 To Grid.MaxRows
            Grid.Row = i
            
            If Grid.RowHidden = False Then
                iCol = 1
                For j = 1 To Grid.MaxCols
                    Grid.Col = j
                    If Grid.ColHidden = False Then
                        Grid.GetText j, i, FValue1
                        xlWs.Cells(iRow, iCol) = "'" & FValue1
                        DoEvents
                        iCol = iCol + 1
                    End If
                Next j
                iRow = iRow + 1
            End If
        Next i
        
 
    xlApp.Selection.CurrentRegion.Columns.AutoFit
    xlApp.Selection.CurrentRegion.Rows.AutoFit

    xlWb.SaveAs (StrFilename)
    xlWb.Close

    xlApp.Quit

    ' Release Excel references
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
''    a1 = VBA.Shell(StrFilename, vbMaximizedFocus)
    

    MsgBox "导出成功!", 48, "金蝶提示"
    
    Screen.MousePointer = 0
    
    Exit Sub
    
AdoTOExcelErr:
    AdoTOExcel = False
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
    Screen.MousePointer = 0
    If Err.Number = 32755 Then Exit Sub
    
    MsgBox Err.Description, vbInformation, pMsgTitle
End Sub