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