module1.vb

一个用vb开发的档案管理程序

Option Strict Off
Option Explicit On
Module Module1
	
	Public Structure RECT
		'UPGRADE_NOTE: Left 已升级到 Left_Renamed。 单击以获得更多信息：'ms-help://MS.VSCC/commoner/redir/redirect.htm?keyword="vbup1061"'
		Dim Left_Renamed As Integer
		Dim Top As Integer
		'UPGRADE_NOTE: Right 已升级到 Right_Renamed。 单击以获得更多信息：'ms-help://MS.VSCC/commoner/redir/redirect.htm?keyword="vbup1061"'
		Dim Right_Renamed As Integer
		Dim Bottom As Integer
	End Structure
	
	Public Const DI_MASK As Integer = 1
	Public Const DI_IMAGE As Integer = 2
	Public Const DI_NORMAL As Integer = 3
	Public Const DI_DEFAULTSIZE As Integer = 8
	Public Const DI_COMPAT As Integer = 4
	Public Const FILE_ATTRIBUTE_ARCHIVE As Integer = &H20s
	Public Const FILE_ATTRIBUTE_COMPRESSED As Integer = &H800s
	Public Const FILE_ATTRIBUTE_DIRECTORY As Integer = &H10s
	Public Const FILE_ATTRIBUTE_HIDDEN As Integer = &H2s
	Public Const FILE_ATTRIBUTE_NORMAL As Integer = &H80s
	Public Const FILE_ATTRIBUTE_READONLY As Integer = &H1s
	Public Const FILE_ATTRIBUTE_SYSTEM As Integer = &H4s
	Public Const FILE_ATTRIBUTE_TEMPORARY As Integer = &H100s
	Public Const MAX_PATH As Integer = 260
	Public Const SHGFI_LARGEICON As Integer = &H0s
	Public Const SHGFI_SMALLICON As Integer = &H1s
	Public Const SHGFI_OPENICON As Integer = &H2s
	Public Const SHGFI_SHELLICONSIZE As Integer = &H4s
	Public Const SHGFI_PIDL As Integer = &H8s
	Public Const SHGFI_USEFILEATTRIBUTES As Integer = &H10s
	Public Const SHGFI_DISPLAYNAME As Integer = &H200s
	Public Const SHGFI_ICON As Integer = &H100s
	Public Const SHGFI_TYPENAME As Integer = &H400s
	Public Const SHGFI_ATTRIBUTES As Integer = &H800s
	Public Const SHGFI_ICONLOCATION As Integer = &H1000s
	Public Const SHGFI_EXETYPE As Integer = &H2000s
	Public Const SHGFI_SYSICONINDEX As Integer = &H4000s
	Public Const SHGFI_LINKOVERLAY As Integer = &H8000
	Public Const SHGFI_SELECTED As Integer = &H10000
	Public Const NOERROR As Integer = 0
	Public Const CSIDL_DESKTOP As Short = &H0s
	Public Const CSIDL_PROGRAMS As Short = &H2s
	Public Const CSIDL_CONTROLS As Short = &H3s
	Public Const CSIDL_PRINTERS As Short = &H4s
	Public Const CSIDL_PERSONAL As Short = &H5s
	Public Const CSIDL_FAVORITES As Short = &H6s
	Public Const CSIDL_STARTUP As Short = &H7s
	Public Const CSIDL_RECENT As Short = &H8s
	Public Const CSIDL_SENDTO As Short = &H9s
	Public Const CSIDL_BITBUCKET As Short = &HAs
	Public Const CSIDL_STARTMENU As Short = &HBs
	Public Const CSIDL_DESKTOPDIRECTORY As Short = &H10s
	Public Const CSIDL_DRIVES As Short = &H11s
	Public Const CSIDL_NETWORK As Short = &H12s
	Public Const CSIDL_NETHOOD As Short = &H13s
	Public Const CSIDL_FONTS As Short = &H14s
	Public Const CSIDL_TEMPLATES As Short = &H15s
	Public Const BIF_RETURNONLYFSDIRS As Short = &H1s
	Public Const BIF_DONTGOBELOWDOMAIN As Short = &H2s
	Public Const BIF_STATUSTEXT As Short = &H4s
	Public Const BIF_RETURNFSANCESTORS As Short = &H8s
	Public Const BIF_BROWSEFORCOMPUTER As Short = &H1000s
	Public Const BIF_BROWSEFORPRINTER As Short = &H2000s
	
	Public Structure SHFILEINFO
		Dim hIcon As Integer
		Dim iIcon As Integer
		Dim dwAttributes As Integer
		<VBFixedString(MAX_PATH),System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValTStr,SizeConst:=MAX_PATH)> Public szDisplayName As String
		<VBFixedString(80),System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValTStr,SizeConst:=80)> Public szTypeName As String
	End Structure
	
	Structure SHITEMID
		Dim cb As Integer
		Dim abID() As Byte
	End Structure
	
	Structure ITEMIDLIST
		Dim mkid As SHITEMID
	End Structure
	
	Public Structure BROWSEINFO
		Dim hOwner As Integer
		Dim pidlRoot As Integer
		Dim pszDisplayName As String
		Dim lpszTitle As String
		Dim ulFlags As Integer
		Dim lpfn As Integer
		Dim lParam As Integer
		Dim iImage As Integer
	End Structure
	
	Public Const SW_RESTORE As Integer = 9
	Public Const GW_CHILD As Integer = 5
	Public Const GW_HWNDNEXT As Integer = 2
	Public Declare Function GetDesktopWindow Lib "user32" () As Integer
	Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Integer, ByVal wCmd As Integer) As Integer
	Public Declare Function GetWindowText Lib "user32"  Alias "GetWindowTextA"(ByVal hwnd As Integer, ByVal lpString As String, ByVal cch As Integer) As Integer
	Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Integer, ByVal nCmdShow As Integer) As Integer
	'UPGRADE_WARNING: 结构 RECT 可能要求封送处理属性作为此声明语句中的参数传递。 单击以获得更多信息：'ms-help://MS.VSCC/commoner/redir/redirect.htm?keyword="vbup1050"'
	Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Integer, ByRef lpRect As RECT) As Integer
	Public Declare Function MoveWindow Lib "user32" (ByVal hwnd As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal bRepaint As Integer) As Integer
	Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Integer) As Integer
	Public Declare Function FindWindow Lib "user32"  Alias "FindWindowA"(ByVal lpClassName As String, ByVal lpWindowName As String) As Integer
	Public Declare Function ShellExecute Lib "shell32.dll"  Alias "ShellExecuteA"(ByVal hwnd As Integer, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Integer) As Integer
	
	Public Declare Function DrawIcon Lib "user32" (ByVal hdc As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal hIcon As Integer) As Integer
	Public Declare Function DrawIconEx Lib "user32" (ByVal hdc As Integer, ByVal xLeft As Integer, ByVal yTop As Integer, ByVal hIcon As Integer, ByVal cxWidth As Integer, ByVal cyWidth As Integer, ByVal istepIfAniCur As Integer, ByVal hbrFlickerFreeDraw As Integer, ByVal diFlags As Integer) As Integer
	'UPGRADE_WARNING: 结构 SHFILEINFO 可能要求封送处理属性作为此声明语句中的参数传递。 单击以获得更多信息：'ms-help://MS.VSCC/commoner/redir/redirect.htm?keyword="vbup1050"'
	Public Declare Function SHGetFileInfo Lib "shell32.dll"  Alias "SHGetFileInfoA"(ByVal pszPath As String, ByVal dwFileAttributes As Integer, ByRef psfi As SHFILEINFO, ByVal cbFileInfo As Integer, ByVal uFlags As Integer) As Integer
	Public Declare Function SHGetPathFromIDList Lib "shell32.dll"  Alias "SHGetPathFromIDListA"(ByVal pIdl As Integer, ByVal pszPath As String) As Integer
	'UPGRADE_WARNING: 结构 ITEMIDLIST 可能要求封送处理属性作为此声明语句中的参数传递。 单击以获得更多信息：'ms-help://MS.VSCC/commoner/redir/redirect.htm?keyword="vbup1050"'
	Public Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Integer, ByVal nFolder As Integer, ByRef pIdl As ITEMIDLIST) As Integer
	'UPGRADE_NOTE: pv 已升级到 pv_Renamed。 单击以获得更多信息：'ms-help://MS.VSCC/commoner/redir/redirect.htm?keyword="vbup1061"'
	Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv_Renamed As Integer)
	'UPGRADE_WARNING: 结构 BROWSEINFO 可能要求封送处理属性作为此声明语句中的参数传递。 单击以获得更多信息：'ms-help://MS.VSCC/commoner/redir/redirect.htm?keyword="vbup1050"'
	Public Declare Function SHBrowseForFolder Lib "shell32.dll"  Alias "SHBrowseForFolderA"(ByRef lpBrowseInfo As BROWSEINFO) As Integer
	
	Public ConData As String
	Public Browser As String
	Public UserText, PurView As String
	Public strSearchString As String
	Public strFileType, strFileID As String
	Public CompanyName As String
	Public ConStr As String
	Public IT As Boolean
	Public TempArray(5) As String
	Public ScanFileName As String
	
	Public Sub GetStatus(ByRef StatusString As String)
		
		frmMain.DefInstance.StatusBar.Panels.Item(2).Text = StatusString
		frmmain.
	End Sub
	
	Public Sub checkPath(ByRef strCorrect As String)
		
		'Dim FS As String, Fn As Long
		' If strCorrect = "" Then
		'    FS = GetSetting(App.EXEName, "Data", "Path")
		'   Else
		'    FS = strCorrect
		' End If
		'    Fn = FreeFile
		'On Error GoTo Exist_Err
		'Open FS For Input As #Fn
		'Close #Fn
		'  ConData = FS
		'  SaveSetting App.EXEName, "Data", "Path", ConData
		'Exit Sub
		
		'Exist_Err:
		
		'  MsgBox vbCrLf & "网 络 路 径 错 误 , 现 在 启 用 本 地 数 据 库 。        " + vbCrLf + vbCrLf + "如 果 需 要 , 请 重 新 定 义 网 络 数 据 库 的 路 径  ！    ", vbOKOnly + vbExclamation, "网络路径错误"
		
		ConData = VB6.GetPath & "\Data\File.Mdb"
		SaveSetting(VB6.GetExeName(), "Data", "Path", ConData)
		
	End Sub
	
	
	Public Sub Main()
		
		Const sBaseCaption As String = "登录窗口"
		Const sBaseCaption1 As String = "FileManager"
		
		Dim hAppWindow As Integer
		Dim sTemp As String
		If (UBound(Diagnostics.Process.GetProcessesByName(Diagnostics.Process.GetCurrentProcess.ProcessName)) > 0) = True Then
			
			hAppWindow = GetWindow(GetDesktopWindow(), GW_CHILD)
			
			Do 
				sTemp = New String(Chr(False), 180)
				Call GetWindowText(hAppWindow, sTemp, 179)
				
				If InStr(sTemp, sBaseCaption) Then
					ActivatePrevInstance((hAppWindow)) '使以前的窗口活动
					Exit Do
				End If
				
				If InStr(sTemp, sBaseCaption1) Then
					ActivatePrevInstance((hAppWindow)) '使以前的窗口活动
					Exit Do
				End If
				
				' 获得下一个子窗体
				hAppWindow = GetWindow(hAppWindow, GW_HWNDNEXT)
			Loop 
		Else
			ConStr = ";UID=;PWD=filemanager"
			
			'第一次运行时
			System.Windows.Forms.Application.Run(frmLogin.DefInstance)
		End If
		
	End Sub
	
	Private Sub ActivatePrevInstance(ByVal hAppWindow As Integer)
		
		Call ShowWindow(hAppWindow, SW_RESTORE)
		
		'使窗口活动
		Call SetForegroundWindow(hAppWindow)
		
		
	End Sub
End Module