mmain.bas

电话本信息 基本上实现电话功能 自己下载侃侃吧

Attribute VB_Name = "mMain"
Option Explicit


Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByValhWnd As Long, ByValwMsg As Long, ByValwParam As Long, lParam As Any) As Long

Public Const EM_UNDO = &HC7

Private Const DataFileName As String = "AddressList.mdb"    '數據庫文件名
Public Const RootName As String = "ZBXX"                    '目錄表名
Public Const ListA As String = "JBXX"                       '用戶基本信息表名
Public Const HaveChindColor As Long = &HFF0000
Public Const NoHaveChindColor As Long = &H0
Public Const LColor = &HFF8080
Public Const LEColor = &H808000

Public Const ImageIndex1 As Long = 1
Public Const ImageIndex2 As Long = 2
Public Const ImageIndex3 As Long = 3
Public Const ImageIndex4 As Long = 4
Public Const ImageIndex5 As Long = 5
Public Const ImageIndex6 As Long = 6
Public Const ImageIndex7 As Long = 7
Public Const ImageIndex8 As Long = 8

Public sBar(2) As String

Public DataCON As ADODB.Connection
Public LangSTR As String, HasChange As Long
Public FindColor As Long, TColor As Long

Sub Main()                  '啟始主函數：打開數據庫，運行MainFrm
  Dim DataPath As String
  
  FindColor = &HFF&
  DataPath = App.Path
  DataPath = DataPath & IIf(Right(DataPath, 1) = "\", DataFileName, "\" & DataFileName)
  If Len(Dir(DataPath, vbHidden Or vbReadOnly Or vbSystem)) = 0 Then
    If MsgBox("未找到数据库，是否重建数据库文件？", vbExclamation Or vbYesNo) <> vbYes Then
      Exit Sub
    Else
      SaveResAsFile 1000, "CUSTOM", DataPath
    End If
  End If
  Set DataCON = OpenDatabass(DataPath)
  If DataCON Is Nothing Then Exit Sub
  LangSTR = "P"
  Load MainFrm
  MainFrm.Show
  sBar(0) = "状态：查询"
  sBar(1) = "状态：编辑"
  sBar(2) = "状态：保存..."
End Sub

Public Function OpenDatabass(ByVal FileName As String, Optional ByVal PassWord As String = vbNullString, Optional ByVal JMMode As Boolean = True) As ADODB.Connection
  Dim ADOCON As ADODB.Connection
  
  On Error Resume Next
  
  Set ADOCON = New ADODB.Connection
  ADOCON.Errors.Clear
  ADOCON.Open "provider=Microsoft.jet.OLEDB.4.0;data source=" & FileName & ";Jet OLEDB:Database PassWord=" & PassWord
  If ADOCON.Errors.Count > 0 Then
    MsgBox "打开数据库时发生错误：" & vbCrLf & "错误代码：" & _
           IIf(ADOCON.Errors(0).Number, ADOCON.Errors(0).Number & Space(4) & vbCrLf & "错误提示：" & ADOCON.Errors(0).Description, _
           ADOCON.Errors(0).Number & Space(4) & vbCrLf & "错误提示：数据被其它用户或程序打开。") & Space(4), vbCritical
    Set ADOCON = Nothing
    Exit Function
  End If
  Set OpenDatabass = ADOCON
End Function

Public Function GetRoot(ByVal Node1 As Object, Optional ByVal Node2 As Object) As Object
  If Node2 Is Nothing Then
    Do While Not (Node1.Parent Is Nothing)
      Set Node1 = Node1.Parent
    Loop
    Set GetRoot = Node1
  Else
    Do While (Node1 <> Node2) And Not (Node1.Parent Is Nothing)
      Set Node1 = Node1.Parent
    Loop
     Set GetRoot = IIf(Node1 = Node2, Node2, Nothing)
  End If
End Function

'从数据库中读取图片(Adodb.Stream)
Public Function ShowImageFromDB(ByVal RsField As ADODB.Field, ImageFileName As String) As Boolean
    Dim ADO_Stream As ADODB.Stream
    
'    On Error GoTo ErrExit
    ShowImageFromDB = False
    If Not IsNull(RsField) Then
        Set ADO_Stream = New ADODB.Stream
        ADO_Stream.Type = adTypeBinary
        ADO_Stream.Open
        ADO_Stream.Write RsField.Value
        ADO_Stream.SaveToFile ImageFileName, adSaveCreateOverWrite
        ADO_Stream.Close
'        Set ShowImageFromDB = LoadPicture(ImageFileName)
        ShowImageFromDB = LoadImage(ImageFileName)
        DoEvents
    End If
    Exit Function
ErrExit:
   Set ADO_Stream = Nothing
End Function

'保存图片到数据库(Adodb.Stream)
Public Function SaveImageToDB(ByVal Rs As ADODB.Recordset, ByVal cFieldName As String, ByVal ImageFileName As String) As Boolean
    Dim ADO_Stream As ADODB.Stream
    
    On Error GoTo SaveImageToDBError
    Set ADO_Stream = New ADODB.Stream
    ADO_Stream.Type = adTypeBinary
    ADO_Stream.Open
    ADO_Stream.LoadFromFile ImageFileName
    Rs.Fields(cFieldName).Value = ADO_Stream.Read
    Rs.Update
    ADO_Stream.Close
    SaveImageToDB = True
SaveImageToDBError:
    Set ADO_Stream = Nothing
End Function

Private Sub SaveResAsFile(ByVal ResID As Long, ByVal ResType As Variant, ByVal FileName As String)
  Dim FileL As Long
  Dim fBuffer() As Byte
  
  On Error Resume Next
  FileL = -1
  fBuffer = LoadResData(ResID, ResType)
  FileL = UBound(fBuffer)
  If FileL = -1 Then Exit Sub
  FileL = FreeFile
  Open FileName For Binary As FileL
  Put FileL, , fBuffer
  Close FileL
End Sub

Public Function GetAppDIR() As String
  GetAppDIR = IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\")
End Function