importphotoform.frm

群里的通讯录管理 供参考 学习专用 无其他商业意义 源码较为简单

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form ImportPhotoForm 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "导入像片"
   ClientHeight    =   5085
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4485
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5085
   ScaleWidth      =   4485
   StartUpPosition =   1  '所有者中心
   Begin MSComDlg.CommonDialog CommDlgOpenFile 
      Left            =   3720
      Top             =   4560
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton cmdClose 
      Caption         =   "关闭"
      Height          =   375
      Left            =   2475
      TabIndex        =   6
      Top             =   4560
      Width           =   975
   End
   Begin VB.CommandButton cmdImport 
      Caption         =   "导入"
      Height          =   375
      Left            =   1035
      TabIndex        =   5
      Top             =   4560
      Width           =   975
   End
   Begin VB.CommandButton cmdBrowFile 
      Caption         =   "浏览..."
      Height          =   300
      Left            =   3360
      TabIndex        =   4
      Top             =   4140
      Width           =   975
   End
   Begin VB.TextBox txtFilePath 
      Height          =   270
      Left            =   1080
      TabIndex        =   3
      Top             =   4155
      Width           =   2175
   End
   Begin VB.Frame Frame1 
      Caption         =   "预览"
      Height          =   3375
      Left            =   120
      TabIndex        =   1
      Top             =   600
      Width           =   4260
      Begin VB.Image ImagePrePhoto 
         Height          =   3015
         Left            =   120
         Stretch         =   -1  'True
         Top             =   240
         Width           =   4020
      End
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "像片文件"
      Height          =   180
      Left            =   120
      TabIndex        =   2
      Top             =   4200
      Width           =   720
   End
   Begin VB.Label lblName 
      BeginProperty Font 
         Name            =   "楷体_GB2312"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FF0000&
      Height          =   255
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   1695
   End
End
Attribute VB_Name = "ImportPhotoForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'***********************************************************************
'* 文件名： ImportPhotoForm.frm
'* 说  明： 导入像片窗口
'* 版  本： 2005.12.15 颜志军 初版
'***********************************************************************

Option Explicit

'***********************************************************************
'模块级变量定义
Private g_peopleId As Long       '人员ID

'***********************************************************************
'* 函数名：MakeDesFileName
'* 功  能：生成目标文件名
'* 参  数：String                       源文件名
'*       ：String                       目标文件名
'* 版  本：2005.12.15 颜志军 初版
'***********************************************************************
Private Function MakeRandFileName(ByVal sourceFile As String) As String
    '变量定义
    Dim dotPos As Integer           '扩展名分隔符位置
    Dim extFileName As String       '扩展名
    Dim masterFileName As String    '文件主名
    Dim curPeopleInfo As PeopleInfo '当前联系统人信息
    Dim curNodeKind As Integer      '当前节点类型
    
    '取得扩展名
    If IsNull(sourceFile) Or IsEmpty(sourceFile) Or sourceFile = "" Then
        dotPos = -1
    Else
        dotPos = InStrRev(sourceFile, ".")
    End If
    If dotPos > 0 Then
        extFileName = Mid(sourceFile, dotPos)
    End If
    
    '生成文件名
    masterFileName = ""
    If MainForm.GetCurrentSelectedNode(curNodeKind, _
        curPeopleInfo.peopleId) Then
        masterFileName = CStr(curPeopleInfo.peopleId)
    End If
    masterFileName = masterFileName & CStr(DatePart("yyyy", Now))
    masterFileName = masterFileName & CStr(DatePart("m", Now))
    masterFileName = masterFileName & CStr(DatePart("d", Now))
    masterFileName = masterFileName & CStr(DatePart("h", Now))
    masterFileName = masterFileName & CStr(DatePart("n", Now))
    masterFileName = masterFileName & CStr(DatePart("s", Now))
    masterFileName = masterFileName & _
        CStr(Int((999 - 100 + 1) * Rnd + 100))

    MakeRandFileName = masterFileName & extFileName
End Function

'***********************************************************************
'* 过程名：MakePhotoFloder
'* 功  能：生成保存像片的目录
'* 参  数：
'* 版  本：2005.12.15 颜志军 初版
'***********************************************************************
Private Sub MakePhotoFloder()
    On Error Resume Next
    MkDir App.Path & "\photo"
End Sub

'***********************************************************************
'* 函数名：AppendNewPhoto2Db
'* 功  能：追加新像片信息到数据库
'* 参  数：String                       像片文件名
'* 版  本：2005.12.16 颜志军 初版
'***********************************************************************
Private Function AppendNewPhoto2Db(ByVal filename As String) As Boolean
    '初始化返回值
    AppendNewPhoto2Db = False
    
    '参数检查
    If IsNull(filename) Or IsEmpty(filename) Or _
            Trim(filename) = "" Then
        Exit Function
    End If
    
    '变量定义
    Dim curPeopleInfo As PeopleInfo '当前联系统人信息
    Dim curNodeKind As Integer      '当前节点类型
    Dim newPhotoInfo As PhotoInfo   '像片信息
    
    If MainForm.GetCurrentSelectedNode(curNodeKind, _
        curPeopleInfo.peopleId) Then
        If curNodeKind <> 2 Then
            Exit Function
        End If
    Else
        Exit Function
    End If
    
    '生成像片信息
    newPhotoInfo.peopleId = curPeopleInfo.peopleId
    newPhotoInfo.photoFile = Trim(filename)
    
    '写入数据库
    AppendNewPhoto2Db = AppendPhoto(newPhotoInfo)
End Function

'***********************************************************************
'* 过程名：cmdBrowFile_Click
'* 功  能：“浏览”按钮单击事件响应
'* 参  数：
'* 版  本：2005.12.15 颜志军 初版
'***********************************************************************
Private Sub cmdBrowFile_Click()
    '变量定义
    Dim curSelFile As String    '当前选择的文件
    
    '打开“打开文件对话框”
    CommDlgOpenFile.filename = ""
    CommDlgOpenFile.Flags = 4096    '文件必须存在
    CommDlgOpenFile.Filter = "JPG|*.JPG|JPEG|*.JPEG|BMP|*.BMP|GIF|*.GIF"
    CommDlgOpenFile.FilterIndex = 1
    CommDlgOpenFile.DialogTitle = "打开像片文件"
    CommDlgOpenFile.ShowOpen
    
    curSelFile = CommDlgOpenFile.filename
    
    '检查文件名
    If IsNull(curSelFile) Or IsEmpty(curSelFile) Or curSelFile = "" Then
        Exit Sub
    End If
    
    '显示文件名
    txtFilePath.Text = curSelFile
    '显示像片
    'ImagePrePhoto.Picture = LoadPicture(curSelFile)
    DspPhoto ImagePrePhoto, curSelFile
End Sub

'***********************************************************************
'* 过程名：Form_Load
'* 功  能：“关闭”按钮单击事件响应
'* 参  数：
'* 版  本：2005.12.15 颜志军 初版
'***********************************************************************
Private Sub cmdClose_Click()
    Me.Hide
End Sub

'***********************************************************************
'* 过程名：cmdImport_Click
'* 功  能：“导入”按钮单击事件响应
'* 参  数：
'* 版  本：2005.12.15 颜志军 初版
'***********************************************************************
Private Sub cmdImport_Click()
    '变量定义
    Dim sourceFile As String    '源文件
    Dim desFile As String       '目标文件
    
    '取得源文件
    sourceFile = Trim(txtFilePath.Text)
    If IsNull(sourceFile) Or IsEmpty(sourceFile) Or sourceFile = "" Then
        MsgBox "请先选择要导入的像片文件！", vbExclamation Or vbOKOnly, "警告"
        Exit Sub
    End If
    
    '生成目标文件
    desFile = MakeRandFileName(sourceFile)
        
    '生成目录
    MakePhotoFloder
    
    '拷贝文件
    On Error GoTo FILECOPYERROR
    FileCopy sourceFile, App.Path & "\photo\" & desFile
    
    '写入数据库
    If AppendNewPhoto2Db(desFile) Then  '成功
        MsgBox "像片已成功导入", vbInformation Or vbOKOnly, "信息"
        txtFilePath.Text = ""   '清空路径
        ImagePrePhoto.Picture = LoadPicture()   '清除预览
    Else    '失败
        Kill App.Path & "\photo\" & desFile '删除已拷贝文件
        GoTo FILECOPYERROR
    End If
    
    Exit Sub
    
FILECOPYERROR:
    MsgBox "导入文件失败！", vbExclamation Or vbOKOnly, "警告"
    Exit Sub
End Sub

'***********************************************************************
'* 过程名：Form_Load
'* 功  能：窗体LOAD事件响应
'* 参  数：
'* 版  本：2005.12.14 颜志军 初版
'***********************************************************************
Private Sub Form_Load()
    '取得当前联系人
    Dim curPeopleInfo As PeopleInfo '当前联系统人信息
    Dim curNodeKind As Integer      '当前节点类型
    
    If MainForm.GetCurrentSelectedNode(curNodeKind, _
        curPeopleInfo.peopleId) And curNodeKind = 2 Then
        If GetSinglePeopleInfo(curPeopleInfo.peopleId, curPeopleInfo) Then
            '显示当前联系人姓名
            lblName.Caption = curPeopleInfo.peopleName
            '初始化随机数生成器
            Randomize
        Else '取得联系人信息失败
            MsgBox "取得联系人信息失败！", vbExclamation Or vbOKOnly, "警告"
            Me.Hide
        End If
    Else
        Me.Hide
    End If
End Sub