mdlmain.bas

利用VB+SQL2000开发的照片管理系统

Attribute VB_Name = "MdlMain"
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const FLAG = SWP_NOMOVE Or SWP_NOSIZE
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const HWND_TOP = 0
Public Const HWND_BOTTOM = 1

Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" _
    (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" _
    (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
    ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public 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
    
'设置桌面背景使用此系统函数
'========================================================================================================================================
    Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
        (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long

    Public Const SPI_SETDESKWALLPAPER = 20
    Public Const SPIF_SENDWININICHANGE = &H2
    Public Const SPIF_UPDATEINIFILE = &H1
'========================================================================================================================================

Public Flash As Boolean             '判定Flash窗口是否从菜单激活
Public ReturnSql As String

Public ServerIsOpen As Boolean      '判定系统数据库是否正确连接。
Public DbConnectSql As String       '系统数据库连接字符串。
Public SysDbPath As String          '系统打印数据库路径；

Public Chunk() As Byte             '保存图片信息。

Public AutoPlay As Boolean          '自动播放控制变量

Public cn As New ADODB.Connection

Private Sub Main()
    If App.PrevInstance = True Then
        MsgBox "系统正在运行,不能同时运行多个实例...", vbCritical + vbOKOnly, "加载错误!!"
        End
    End If

    SysDbPath = App.Path & "\chxn"
    ' 定义Connection对象的连接字符串，通过此连接字符串连接到一实际数据库，例
    ' 如本设计应连接到一SQL2000数据库，应使用以下的连接字符串；
    DbConnectSql = "dsn=picdb;uid=sa;pwd=;"
    
    ' 定义Connection对象的连接字符串，通过此连接字符串连接到一实际数据库，如果使用ACCESS数据库
    ' 则使用下面的连接字符串：
    'DbConnectSql = "provider=microsoft.jet.oledb.4.0;data source=" & _
        SysDbPath & "\maindb.mdb;jet oledb:database password=;"
    
TryAgain:
    FrmTestSql.Show vbModal
    If ServerIsOpen = False Then
        MsgBox "请检查数据库是否正确运行！！" & Chr$(13) & Chr$(10) & Chr$(13) _
            & "按“确定”退出程序...", vbOKOnly + vbInformation, "打不开数据库"
        End
    End If
    
    AutoPlay = False
    
    Flash = False
    cn.Open DbConnectSql
    FrmFlash.Show

End Sub

Public Function Image2Chunk(Filename As String) As Variant
    On Error GoTo ProcErr
    Dim Datafile As Integer             '用来对图片文件进行处理的文件句柄
    Dim FileLength As Long              '图片文件长度
    Dim PChunk() As Byte            '临时保存图片文件的二进制数据结构
    
    Datafile = FreeFile                 '释放文件句柄
    Open Filename For Binary Access Read As Datafile        '打开文件句柄
        FileLength = LOF(Datafile)                          '根据文件句柄返回文件长度
        If FileLength = 0 Then GoTo ProcErr
        ReDim PChunk(FileLength)                            '重新定义数据结构：PChunk() 的长度
        Get Datafile, , PChunk()                            '取文件到数据结构：PChunk() 中
    Close Datafile
    
ProcExit:
    Image2Chunk = PChunk()                                  '返回保存了图片资料的数据结构给：Image2Chunk
    Exit Function

ProcErr:
    Image2Chunk = 0
End Function

Public Function Chunk2Image(PChunk() As Byte, Optional Filename As String) As Variant
    On Error GoTo ProcErr
    Dim KeepFile As Boolean
    Dim Datafile As Integer

    KeepFile = True
    If Trim(Filename) = "" Then
        Filename = App.Path & "\namzy.fil"
        KeepFile = False
    End If

    Datafile = FreeFile                 '释放文件句柄
    Open Filename For Binary Access Write As Datafile        '打开文件句柄
        Put Datafile, , PChunk()
    Close Datafile

ProcExit:
    Set Chunk2Image = LoadPicture(Filename)
    On Error Resume Next
    If Not KeepFile Then Kill Filename
    Exit Function

ProcErr:
    On Error Resume Next
    If Not KeepFile Then Kill Filename
    Chunk2Image = 0
End Function