vbemuldb.frm

《Windows CE 权威指南》（作者：(美)CHRIS MUENCH

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Mdb to Emulator"
   ClientHeight    =   2970
   ClientLeft      =   6705
   ClientTop       =   5475
   ClientWidth     =   7080
   BeginProperty Font 
      Name            =   "Arial"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   2970
   ScaleWidth      =   7080
   Begin VB.CommandButton cmdCopyEmul 
      Caption         =   "Copy to Emulator"
      Enabled         =   0   'False
      Height          =   495
      Left            =   5880
      TabIndex        =   6
      Top             =   2280
      Width           =   1095
   End
   Begin VB.ListBox List1 
      Height          =   1740
      Left            =   120
      TabIndex        =   4
      Top             =   1080
      Width           =   5655
   End
   Begin VB.CommandButton cmdBrowse 
      Caption         =   "&Select DB..."
      Height          =   375
      Left            =   5880
      TabIndex        =   3
      Top             =   360
      Width           =   1095
   End
   Begin MSComDlg.CommonDialog FileOpenDialog 
      Left            =   6360
      Top             =   360
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      DialogTitle     =   "Pick an MDB"
      Filter          =   "Database Files (*.mdb) | *.mdb"
      InitDir         =   "\"
   End
   Begin VB.TextBox Text1 
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   120
      Locked          =   -1  'True
      TabIndex        =   0
      Top             =   360
      Width           =   5655
   End
   Begin VB.CommandButton cmdConvert 
      Caption         =   "&Convert DB"
      Enabled         =   0   'False
      Height          =   375
      Left            =   5880
      TabIndex        =   1
      Top             =   1080
      Width           =   1095
   End
   Begin VB.Label Label1 
      Caption         =   "Please select a DB to convert to text."
      Height          =   255
      Left            =   120
      TabIndex        =   2
      Top             =   120
      Width           =   4695
   End
   Begin VB.Label Label2 
      Caption         =   "Tables to Convert"
      Height          =   255
      Left            =   120
      TabIndex        =   5
      Top             =   840
      Width           =   2655
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF
'ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO
'THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A
'PARTICULAR PURPOSE.

'Copyright  1998  Microsoft Corporation.  All Rights Reserved



Option Explicit

Private Type STARTUPINFO
    cb As Long
    lpReserved As String
    lpDesktop As String
    lpTitle As String
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Long
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type

Private Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessID As Long
   dwThreadID As Long
End Type

Private Declare Function WaitForSingleObject Lib "kernel32" ( _
    ByVal hHandle As Long, _
    ByVal dwMilliseconds As Long) As Long

Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
    lpApplicationName As Long, _
    ByVal lpCommandLine As String, _
    ByVal lpProcessAttributes As Long, _
    ByVal lpThreadAttributes As Long, _
    ByVal bInheritHandles As Long, _
    ByVal dwCreationFlags As Long, _
    ByVal lpEnvironment As Long, _
    ByVal lpCurrentDirectory As Long, _
    lpStartupInfo As STARTUPINFO, _
    lpProcessInformation As PROCESS_INFORMATION) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&



Dim db As Database
Dim tbl As TableDef
Dim fld As Field
Dim idx As Index
Dim rs As Recordset
Dim LogFilePath As String



'-------------------------------------------------------------------------
' This Sub makes sure that the User has selected a path.
' It then opens the Mdb file and passes it to MainSub
'------------------------------------------------------------------------


Sub cmdConvert_Click()

    Dim MdbPath As String
    
    MdbPath = frmMain.Text1.Text
    
    If MdbPath = "" Then
        MsgBox "Please use the browse button to select a Access Database to convert"
    Else
        
        Me.MousePointer = vbHourglass
        
        Set db = OpenDatabase(MdbPath)
        Call MainSub(db)
        
        ' Put in an End Of File Marker
        WriteString ("End Of File")
        
        Me.MousePointer = vbDefault
        
        frmMain.cmdCopyEmul.Enabled = True
        frmMain.cmdBrowse.Enabled = False
        frmMain.cmdConvert.Enabled = False
        
        
        MsgBox "DB Converted to TDB format [ " & LogFilePath & " ]" ' Finished converting the the MDB to Text
        
        
    End If
    
End Sub


Private Sub cmdBrowse_Click()
    Dim filename As String
    Dim SelectedTbl As String
    
    FileOpenDialog.Action = 1
    
    If FileOpenDialog.filename = "" Then
        Exit Sub
    End If
    
    filename = FileOpenDialog.filename
    LogFilePath = Left(filename, Len(filename) - 3) & "tdb"
    ' delete any previous version of the TDB file
    On Error Resume Next
    Kill LogFilePath
    On Error GoTo ErrorHandler ' Turn on an error trap for the OpenDatabase statement
    Set db = OpenDatabase(filename)
    On Error GoTo 0 ' Turn off Error Handling
    
    frmMain.Text1.Text = filename
    frmMain.List1.Clear ' Clears any list entries
    
    For Each tbl In db.TableDefs
    
        Select Case tbl.Attributes
            
            Case 0     ' No Attributes
            
            If UCase(Left(tbl.Name, 4)) <> "MSYS" Then

                frmMain.List1.AddItem tbl.Name
                
            End If
            
        End Select
        
    Next
    
    db.Close
    Set db = Nothing
    
    frmMain.cmdConvert.Enabled = True

ErrorHandler:
    If Err.Number > 0 Then
        MsgBox "Error Number [" & Err.Number & "]" & vbCrLf & "Error Description [" & Err.Description & "]"
    End If
End Sub


Sub MainSub(db As Database)

    For Each tbl In db.TableDefs
    
        Select Case tbl.Attributes
        
            Case 0      ' No Attributes
            
                If UCase(Left(tbl.Name, 4)) <> "MSYS" Then
                    'skip CE system conflict tables
                    Call CreateTblStr(tbl)
                    Call CreateIdxStr(tbl)
                    Call WriteRecords(db, tbl)
                    
                End If
            
            Case Else
            
        End Select
        
    Next
    
End Sub


Sub CreateTblStr(tbl As TableDef)

    Dim DropTable As String
    Dim CreateTable As String
    
    CreateTable = "CREATE TABLE [" & tbl.Name & "] ("
        
        For Each fld In tbl.Fields
            
            If fld.Type <> dbBinary Or fld.Type <> dbLongBinary Or fld.Type <> dbGUID Or fld.Type <> dbVarBinary Then
            
                CreateTable = CreateTable & "[" & fld.Name & "] " & GetType(fld.Type) & ", "
            
            End If
        
        Next
    
    DropTable = "DROP TABLE [" & tbl.Name & "]" ' Writing a Drop table command to clean up any existing tables with the same name
    
    WriteString (DropTable)
    
    CreateTable = Left(CreateTable, Len(CreateTable) - 2) & ")"
    
    WriteString (CreateTable)
    
End Sub

Sub CreateIdxStr(tbl As TableDef)

    Dim CreateIndex As String
    
    For Each idx In tbl.Indexes
        
        If idx.Primary = True Then
            
            If idx.Fields.Count = 1 Then
                CreateIndex = "CREATE INDEX [" & idx.Name & "] ON [" & tbl.Name & "] ([" & idx.Fields(0).Name & "])"
            End If
            
        End If
        
    Next
    
    WriteString (CreateIndex)

End Sub


Sub WriteRecords(db As Database, tbl As TableDef)
    Dim Y As Long
    Dim InsertStr As String
    Dim FldArray As Variant
    Set rs = db.OpenRecordset(tbl.Name)
    ReDim FldArray(0 To tbl.Fields.Count - 1)
    
  
    Do While Not rs.EOF
        Y = 0 ' Set Field Loop counter to zero
        For Each fld In rs.Fields
          
            Select Case fld.Type
                Case 9, 11, 15
                    FldArray(Y) = Null
                Case Else
                
                    If IsNull(fld.Value) = True Then
                        FldArray(Y) = Null
                    Else
                    
                        FldArray(Y) = fld.Name
                            If QuoteStr(fld.Type) = True Then
                                InsertStr = InsertStr & StripChar(fld.Value) & ", "
                            Else
                                InsertStr = InsertStr & fld.Value & ", "
                            End If
                        
                    End If
            End Select
        Y = Y + 1
        Next
        
        InsertStr = "INSERT INTO [" & tbl.Name & "] (" & FieldList(FldArray) & ") values (" & Left(InsertStr, Len(InsertStr) - 2) & ")"
        WriteString (InsertStr)
        InsertStr = ""
        rs.MoveNext
    Loop
    
End Sub


Function StripChar(ByVal FieldVal As Variant) As String

    Dim ReplaceChar As Variant
    Dim TxtFieldVal As String
    Dim ChrPos As Integer
    TxtFieldVal = FieldVal
    
    For Each ReplaceChar In Array(Chr$(13), Chr$(10), Chr(34))
        
        Do
            ChrPos = InStr(1, TxtFieldVal, ReplaceChar)
            If (ChrPos > 0) Then
                Mid(TxtFieldVal, ChrPos, Len(ReplaceChar)) = " "
            End If
        
        Loop While (ChrPos > 0)
    
    Next ReplaceChar
' <BOOK_ADDON Chapter 8.5.1> *******************************
    ChrPos = 1
    While Mid(TxtFieldVal, ChrPos, 1) <> Chr$(0) And _
    ChrPos < Len(TxtFieldVal)
        ChrPos = ChrPos + 1
    Wend
    TxtFieldVal = Left(TxtFieldVal, ChrPos - 1)
' </BOOK_ADDON Chapter 8.5.1> *******************************
    
    StripChar = Chr(34) & TxtFieldVal & Chr(34)
    
End Function

Function FieldList(Fldlist As Variant)
    Dim X As Integer
    Dim TempStr As String
    
    For X = 0 To UBound(Fldlist)
    
        If IsNull(Fldlist(X)) <> True Then
            TempStr = TempStr & "[" & Fldlist(X) & "], "
        End If
        
    Next
    
    TempStr = Left(TempStr, Len(TempStr) - 2)
    FieldList = TempStr
    
End Function

Function QuoteStr(fldType)

    Select Case fldType
        
        Case dbBoolean, dbByte, dbInteger, dbLong, dbCurrency, dbSingle, dbDouble, dbBinary, dbLongBinary, 14, dbGUID, dbVarBinary, dbNumeric, dbFloat
            
            QuoteStr = False
        
        Case dbDate, dbText, dbMemo
            
            QuoteStr = True
        
        Case Else
            
            QuoteStr = "UN-SUPPORTED-TYPE - " & fldType
            
    End Select

End Function

Function GetType(fldType As Integer)

    Dim DeviceType As String
    
    Select Case fldType
        Case dbBoolean
            DeviceType = "BIT"
        
        Case dbByte
            DeviceType = "SMALLINT"
        
        Case dbInteger, dbLong
            DeviceType = "INT"
                
        Case dbCurrency, dbSingle, dbDouble
            DeviceType = "FLOAT"
        
        Case dbDate
            DeviceType = "DATETIME"
        
        Case dbBinary, dbLongBinary, dbGUID, dbVarBinary
            DeviceType = "VARBINARY"
        
        Case dbText, dbMemo
            DeviceType = "TEXT"
        
        Case "14"
            
            DeviceType = "INT"
        
        Case Else
            
            DeviceType = "UN-SUPPORTED-TYPE - " & fldType
    
    End Select
    
    GetType = DeviceType

End Function

Sub WriteString(Str As String)

    Open LogFilePath For Append Shared As #1
    
    Print #1, Str
    
    Close #1

End Sub

'----------------------------------------------------------------
' Copy to the emulator Procedures
'----------------------------------------------------------------


Private Sub cmdCopyEmul_Click()
    
    Dim xfer As String
    Dim filename As String
    Dim extpos As Integer
    Dim slshpos As Integer
    Dim idx As Integer
    
    ' set current directory to the root of the current drive
    Me.MousePointer = vbHourglass

    ChDir "\"
    
    extpos = InStr(1, LogFilePath, ".tdb")
    
    For idx = extpos - 1 To 1 Step -1
        slshpos = InStr(idx - 1, LogFilePath, "\")
        If slshpos <> 0 Then Exit For
    Next idx
    
    filename = Mid$(LogFilePath, slshpos + 1)
' <BOOK_CHANGE Chapter 8.5.1> *******************************
    xfer = "empfile -c " & Chr(34) & LogFilePath & Chr(34) & " " & Chr$(34) & "WCE:\windows" & Chr$(34)
' </BOOK_CHANGE Chapter 8.5.1> *******************************
    ExecCmd xfer
    
    Me.MousePointer = vbDefault
    
    frmMain.cmdBrowse.Enabled = True
    frmMain.cmdCopyEmul.Enabled = False
    
End Sub



Public Sub ExecCmd(cmdline$)

    Dim ret As Long
    Dim proc As PROCESS_INFORMATION
    Dim start As STARTUPINFO
    
    ' Initialize the STARTUPINFO structure:
    start.cb = Len(start)
    
    ' Start the shelled application:
    ret = CreateProcessA(0&, cmdline$, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
    
    ' Wait for the shelled application to finish:
    ret = WaitForSingleObject(proc.hProcess, INFINITE)
    ret = CloseHandle(proc.hProcess)
    
End Sub