Visual Basic Source Code

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / as2db1 / general.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1994-01-07 | 31.7 KB | 964 lines

VERSION 2.00 Begin Form Form1 AutoRedraw = -1 'True BackColor = &H00C0C0C0& BorderStyle = 1 'Fixed Single Caption = "ASC2MDB" ClientHeight = 4905 ClientLeft = 1560 ClientTop = 1920 ClientWidth = 5400 FillStyle = 0 'Solid Height = 5595 Icon = GENERAL.FRX:0000 Left = 1500 LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 4905 ScaleWidth = 5400 Top = 1290 Width = 5520 Begin CommandButton cmdTranslate Caption = "&Start" Default = -1 'True Height = 375 Left = 3600 TabIndex = 0 Top = 3240 Width = 1455 End Begin CommandButton cmdExit Cancel = -1 'True Caption = "E&xit" Height = 375 Left = 3600 TabIndex = 1 Top = 3840 Width = 1455 End Begin Frame Frame1 BackColor = &H00C0C0C0& Height = 495 Left = -10 TabIndex = 15 Top = 4440 Width = 5425 Begin SSPanel pnlStatus BevelOuter = 1 'Inset FontBold = -1 'True FontItalic = -1 'True FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H000000FF& Height = 255 Left = 80 TabIndex = 16 Top = 165 Width = 5260 End End Begin SSFrame Frame3D5 Caption = "Replace Mode:" ForeColor = &H00000000& Height = 615 Left = 120 TabIndex = 14 Top = 2280 Width = 5175 Begin Label lblReplaceMode BackColor = &H00C0C0C0& Height = 255 Left = 120 TabIndex = 9 Top = 240 Width = 4815 End End Begin SSFrame Frame3D4 Caption = "Table Destination: " ForeColor = &H00000000& Height = 615 Left = 120 TabIndex = 12 Top = 1560 Width = 5175 Begin Label lblCurrTable BackColor = &H00C0C0C0& Height = 255 Left = 120 TabIndex = 13 Top = 240 Width = 4815 End End Begin SSFrame frameTableProcessing Caption = "Table Processing" ForeColor = &H00000000& Height = 1335 Left = 120 TabIndex = 10 Top = 3000 Width = 3135 Begin Gauge Gauge1 Autosize = -1 'True BackColor = &H0080FFFF& ForeColor = &H000000FF& Height = 360 InnerBottom = -5 InnerLeft = -5 InnerRight = -5 InnerTop = -5 Left = 240 Max = 100 NeedleWidth = 1 TabIndex = 11 Top = 360 Visible = 0 'False Width = 2655 End Begin Label lblElapsedTime Alignment = 2 'Center BackStyle = 0 'Transparent Height = 255 Left = 120 TabIndex = 6 Top = 360 Visible = 0 'False Width = 2775 End Begin Label lblRecCount Alignment = 2 'Center BackStyle = 0 'Transparent Height = 255 Left = 120 TabIndex = 7 Top = 960 Width = 2775 End Begin Label lblDBCount Alignment = 2 'Center BackStyle = 0 'Transparent Height = 255 Left = 120 TabIndex = 8 Top = 660 Visible = 0 'False Width = 2775 End End Begin SSFrame Frame3D2 Caption = "Database Destination File:" ForeColor = &H00000000& Height = 615 Left = 120 TabIndex = 4 Top = 840 Width = 5175 Begin Label lblCurrDatabase BackColor = &H00C0C0C0& Height = 255 Left = 120 TabIndex = 5 Top = 240 Width = 4815 End End Begin SSFrame Frame3D1 Caption = "ASCII Source File:" ForeColor = &H00000000& Height = 615 Left = 120 TabIndex = 3 Top = 120 Width = 5175 Begin Label lblCurrInput BackColor = &H00C0C0C0& Height = 255 Left = 120 TabIndex = 2 Top = 240 Width = 4815 End End Begin CommonDialog cmdlg1 Left = 360 Top = 3240 End Begin Menu mnuFile Caption = "&File" Begin Menu mnuFileExit Caption = "E&xit" End End Begin Menu mnuEdit Caption = "&Edit" Begin Menu mnuEditInput Caption = "&ASCII Source" End Begin Menu mnuEditMDB Caption = "&MDB Destination" End Begin Menu mnuEditTable Caption = "&Table Destination" End Begin Menu mnuSep0 Caption = "-" End Begin Menu mnuEditReplMode Caption = "&Replace Mode" End End Begin Menu mnuHelp Caption = "&Help" Begin Menu mnuHelpContents Caption = "Help &Contents" End Begin Menu mnuSep1 Caption = "-" End Begin Menu mnuHelpAbout Caption = "&About" End End ' ASC2MDB 'copyright 1993 by Richard Curzon 'May be used freely as a personal utility but may not ' be sold without express permission from the author 'May be copied for personal use under these terms Option Explicit Dim InFileNum As Integer 'input file number, for emergency close Dim localErrFileName 'copy of gcErrFileName that may be modified 'by command line Dim AscErrorFlag As Integer Sub AddNewOrSeekEdit (InFileLine) Select Case ReplaceMode Case Is < 4 gTabOut.AddNew Case Else gTabOut.Index = Mode45Index() 'func in SPECIFIC.BAS gTabOut.Seek "=", Mid(InFileLine, gIOFld(Mode345Key()).inStart, gIOFld(Mode345Key()).inLength) If gTabOut.NoMatch And ReplaceMode = 4 Then gTabOut.AddNew Else gTabOut.Edit End If End Select End Sub Private Sub CheckBlockDeleteKey (InFileLine) 'Replace Mode 3 only, block delete Dim SQL Dim Msg, LogMsg Dim CandidateValue Dim KeyFound As Integer Dim TestBDKey As Integer Dim ds As DynaSet pnlStatus = "deleting block...": DoEvents TestBDKey = Mode345Key() 'Func in SPECIFIC.BAS CandidateValue = Mid(InFileLine, gIOFld(TestBDKey).inStart, gIOFld(TestBDKey).inLength) If gIOFld(TestBDKey).dbType = DB_TEXT Then CandidateValue = "'" & CandidateValue & "'" On Error GoTo BDError pnlStatus = "counting records...": DoEvents SQL = "SELECT count([" & gIOFld(TestBDKey).dbName SQL = SQL & "]) as itemCount FROM [" & gTabOut SQL = SQL & "] WHERE [" & gIOFld(TestBDKey).dbName SQL = SQL & "] = " & CandidateValue Set ds = thisDb.CreateDynaset(SQL) pnlStatus = "finished counting records...": DoEvents LogMsg = "field used as delete attribute: " & gIOFld(TestBDKey).dbName & NL LogMsg = LogMsg & "delete criterion: " & CandidateValue & NL LogMsg = LogMsg & "records matching delete criterion: " & ds!itemCount & NL Logline LogMsg 'allow the user to abort anyway... Msg = ds!itemCount & " records will be deleted from the" & NL Msg = Msg & "existing table """ & lblCurrTable & """" & NL Msg = Msg & "existing file """ & lblCurrDatabase & """" & NL Msg = Msg & " where the field """ & gIOFld(TestBDKey).dbName & """" & NL Msg = Msg & " is """ & CandidateValue & """" & NL & NL Msg = Msg & "DO YOU WANT TO ABORT?" ans = MsgBox(Msg, MB_YESNO + MB_APPLMODAL + MB_ICONQUESTION, "Block Delete Abort Dialog") If ans = idyes Then gTabOut.Close ds.Close thisDb.Close Logline "User aborted." & NL End End If 'Okay, if you insist -- say good bye to your records... pnlStatus = "deleting old records...": DoEvents SQL = "DELETE from [" & gTabOut & "] WHERE [" SQL = SQL & gIOFld(TestBDKey).dbName SQL = SQL & "] = " & CandidateValue thisDb.Execute SQL pnlStatus = "processing input records...": DoEvents On Error GoTo 0 Exit Sub BDError: If Err = 3021 Then Resume Next '3021: No current record: failed to find a ' record meeting criteria Msg = "CheckBlockDeleteError:" & NL Msg = Msg & Err & " : " & Error & NL Msg = Msg & "Suggestion: Check 1st record of input file" & NL MsgBox Msg End End Sub Sub CheckFields () 'this SUB shouldn't need customizing Dim Msg Dim ErrCount Dim Looper As Integer Msg = "Checking field definitions..." & NL ErrCount = 0 On Error GoTo CheckError0 For Looper = 1 To UBound(gIOFld) If Len(gIOFld(Looper).dbName) = 0 Then Msg = Msg & "IO Fld " & Looper & " may be missing" & NL Error 32000 End If If gIOFld(Looper).dbType = DB_TEXT Then End If Select Case gIOFld(Looper).dbType Case DB_BOOLEAN If gIOFld(Looper).dbSize <> 1 Then Msg = Msg & "DB_BOOLEAN S/B dbSize 1" & NL Error 32000 End If Case DB_BYTE If gIOFld(Looper).dbSize <> 1 Then Msg = Msg & "DB_BYTE s/b dbSize 1" & NL Error 32000 End If Case DB_INTEGER If gIOFld(Looper).dbSize <> 2 Then Msg = Msg & "DB_INTEGER s/b dbSize 2" & NL Error 32000 End If Case DB_CURRENCY If gIOFld(Looper).dbSize <> 8 Then Msg = Msg & "DB_CURRENCY s/b dbSize 8" & NL Error 32000 End If Case DB_SINGLE If gIOFld(Looper).dbSize <> 4 Then Msg = Msg & "DB_SINGLE s/b dbSize 4" & NL Error 32000 End If Case DB_DOUBLE If gIOFld(Looper).dbSize <> 8 Then Msg = Msg & "DB_DOUBLE s/b dbSize 8" & NL Error 32000 End If Case DB_LONG If gIOFld(Looper).dbSize <> 4 Then Msg = Msg & "DB_LONG s/b dbSize 4" & NL Error 32000 End If Case DB_DATE If gIOFld(Looper).dbSize <> 8 Then Msg = Msg & "DB_DATE s/b dbSize 8" & NL Error 32000 End If Case DB_TEXT If gIOFld(Looper).dbSize > 255 Or gIOFld(Looper).dbSize < 1 Then Msg = Msg & "DB_TEXT s/b dbSize 1-255" & NL Error 32000 End If If gIOFld(Looper).dbSize <> gIOFld(Looper).inLength Then Msg = Msg & "DB_TEXT length discrepancy" & NL Error 32000 End If Case DB_LONGBINARY If gIOFld(Looper).dbSize <> 0 Then Msg = Msg & "DB_LONGBINARY s/b dbSize 0" & NL Error 32000 End If Case DB_MEMO If gIOFld(Looper).dbSize <> 0 Then Msg = Msg & "DB_MEMO s/b dbSize 0" & NL Error 32000 End If Case Else Msg = Msg & "Not a valid database dbType: " & gIOFld(Looper).dbType & NL Error 32000 End Select Next Looper If ErrCount > 0 Then Msg = "Errors, please fix before continuing" Beep MsgBox Msg End If Exit Sub CheckError0: ErrCount = ErrCount + 1 Msg = "Checking field definitions..." & NL Msg = Msg & "Check figures in Field """ & gIOFld(Looper).dbName & """" MsgBox Msg Resume Next 'aborts later if Errcount > 0 End Sub Sub CheckIndexes () 'this SUB shouldn't need customizing Dim Msg Dim Looper As Integer Dim ErrCount As Integer Dim Primarycount As Integer Dim FldCount As Integer Msg = "Checking index definitions..." & NL Primarycount = 0 ErrCount = 0 On Error GoTo CheckError1 If UBound(gIndexPtrn) = 0 Then Exit Sub For Looper = 1 To UBound(gIndexPtrn) If Len(gIndexPtrn(Looper).Name) = 0 Then Msg = "Index " & Looper & " may be missing" & NL Error 32000 End If If gIndexPtrn(Looper).Primary = True Then Primarycount = Primarycount + 1 If gIndexPtrn(Looper).Unique = False Then MsgBox "NOTE: " & gIndexPtrn(Looper).Name & " Index is Primary, so will be Unique!" End If CheckThisKey (Looper) If Primarycount > 1 Then Msg = "More than one index is marked ""Primary""" & NL Primarycount = 1 ' to trap next one too Error 32000 End If Next Looper If ErrCount > 0 Then Msg = "Errors, please fix before continuing" Beep MsgBox Msg End If Exit Sub CheckError1: ErrCount = ErrCount + 1 Msg = Msg & "Check figures in Key """ & gIndexPtrn(Looper).Name & """" MsgBox Msg Msg = "checking index definitions..." & NL Resume Next 'aborts later if errcount > 0 End Sub Private Sub CheckThisKey (Ind) Dim Msg Dim iInd As Integer 'index counter Dim iFld As Integer 'index counter Dim ErrCount As Integer Dim iKeys() As String ' array of keys in index Dim cKeys As Integer ' count the keys Dim KeyFound As Integer 'is the index key a valid field name Dim iMarker As Integer ' mark off the dbnames in key Dim remKeys As String ' working temporary 'sample input: gIndexPtrn(3).Fields = "DTN;Phone" cKeys = 1 ReDim iKeys(cKeys) remKeys = gIndexPtrn(Ind).Fields iMarker = InStr(remKeys, ";") Msg = "" On Error GoTo CheckError2 'make the array of keys Do While iMarker > 0 iKeys(cKeys) = Mid(remKeys, 1, iMarker - 1) remKeys = Mid(remKeys, iMarker + 1, Len(remKeys)) cKeys = cKeys + 1 ReDim Preserve iKeys(cKeys) iMarker = InStr(remKeys, ";") Loop iKeys(cKeys) = remKeys 'compare the array to the actual fields in the database For iInd = 1 To cKeys KeyFound = False For iFld = 1 To UBound(gIOFld) If iKeys(iInd) = gIOFld(iFld).dbName Then KeyFound = True Exit For End If Next iFld If Not KeyFound Then Msg = "Key not found: """ & iKeys(iInd) & """" & NL Msg = Msg & "Index Name """ & gIndexPtrn(Ind).Name & """" & NL Msg = Msg & "Index Number " & Ind & NL Error 32000 End If If Len(iKeys(cKeys)) < 1 Then Msg = "Null key for index """ & gIndexPtrn(Ind).Name & """" & NL Msg = Msg & "Index Number " & Ind & NL Error 32000 End If Next iInd If ErrCount > 0 Then Msg = "Errors, please fix before continuing" Beep MsgBox Msg End If Exit Sub CheckError2: ErrCount = ErrCount + 1 MsgBox Msg Resume Next End Sub Sub cmdExit_Click () If Not gRunning Then Unload Me Else ans = MsgBox("Job is running, do you want to abort?", MB_YESNO + MB_APPLMODAL + MB_ICONQUESTION, "Exit button pushed") If ans = idyes Then Logline "User Aborted." & NL Close InFileNum If Not gTabOut Is Nothing Then gTabOut.Close End If If Not thisDb Is Nothing Then thisDb.Close End If End End If End If End Sub Sub cmdTranslate_Click () Dim Msg, LogMsg Dim StVal If gRunning Then Beep: Exit Sub Dim Looper As Integer Dim filelength As Long Dim StartTime, FinTime Dim InFileLine As String Dim InLineCount As Integer Dim OutlineCount As Integer Dim ErrFileNum As Integer Dim BadLineCount As Integer Dim GraphUnit As Integer lblElapsedTime.Visible = False lblDBCount.Visible = False lblRecCount = "" If ReplaceMode > 2 Then ValidateMode345Key On Error GoTo FileOpenError 'setup for reading records InFileNum = FreeFile Open lblCurrInput For Input As InFileNum Len = 500 filelength = LOF(InFileNum) GraphUnit = ((filelength / RecordLen) / 50) + 1 If GraphUnit > 100 Then GraphUnit = 100 Screen.MousePointer = 11 ' cursor hourglass LogMsg = "starting processing..." & NL LogMsg = LogMsg & "ReplaceMode is " & ReplaceMode & NL If ReplaceMode > 3 Then LogMsg = LogMsg & "Mode345Key is " & Mode345Key() & " (" & gIOFld(Mode345Key()).dbName & ")" & NL LogMsg = LogMsg & "Mode45Index is " & Mode45Index() & NL End If LogMsg = LogMsg & "ASCII input from: " & lblCurrInput & NL LogMsg = LogMsg & "updated database: " & lblCurrDatabase & NL LogMsg = LogMsg & "to table named : " & lblCurrTable & NL Logline LogMsg ReadyDatabase 'depends on ReplaceMode 0/12345 ReadyTable 'depends on ReplaceMode 01/2345 gRunning = True 'so we can check before allowing exit pnlStatus = "processing input records... ": DoEvents Gauge1.Visible = True On Error GoTo ErrorLogEntry StartTime = Timer ' init local variables InLineCount = 0 OutlineCount = 0 BadLineCount = 0 Do While Not EOF(InFileNum) InLineCount = InLineCount + 1 If InLineCount Mod GraphUnit = 0 Then Gauge1.Value = Int((Loc(InFileNum) * 128 / filelength) * 100) lblRecCount = InLineCount & " read " & BadLineCount & " errs" DoEvents End If DoEvents Line Input #InFileNum, InFileLine If PassFilter(InFileLine) Then AddNewOrSeekEdit (InFileLine) 'depends on ReplaceMode If ReplaceMode = 3 Then If OutlineCount + BadLineCount = 0 Then CheckBlockDeleteKey (InFileLine) End If If Len(InFileLine) <> RecordLen Then Msg = "Line too short or too long (check for tabs)" & NL Error (32767) End If For Looper = 1 To UBound(gIOFld) Msg = "" StVal = Mid(InFileLine, gIOFld(Looper).inStart, gIOFld(Looper).inLength) gTabOut(gIOFld(Looper).dbName) = IIf(gIOFld(Looper).dbType < 10 And Trim(StVal) = "", Null, StVal) Next gTabOut.Update OutlineCount = OutlineCount + 1 ErrorResume: End If Loop Gauge1.Visible = False FinTime = Timer lblElapsedTime.Visible = True lblDBCount.Visible = True lblElapsedTime = "elapsed: " & Int(FinTime - StartTime) & " sec" & NL Msg = "operation finished" & NL Msg = Msg & "table load time: " & Int(FinTime - StartTime) & " sec" & NL lblDBCount = OutlineCount & " recs saved" Msg = Msg & OutlineCount & " recs saved" & NL lblRecCount = InLineCount & " read " & BadLineCount & " errs" Msg = Msg & InLineCount & " read " & BadLineCount & " errs" & NL Logline Msg pnlStatus = "closing files...": DoEvents Close InFileNum: gTabOut.Close : thisDb.Close Screen.MousePointer = 0 ' cursor normal pnlStatus = "done; log file " & localErrFileName: DoEvents gRunning = False Exit Sub FileOpenError: Msg = Err & " " & Error & NL Msg = Msg & " on opening ascii input file" MsgBox Msg End ErrorLogEntry: LogError BadLineCount, Msg, InLineCount, InFileLine Resume ErrorResume Exit Sub End Sub Sub Form_Load () ' ASC2MDB: a tool to transfer ASCII records ' into MS ACCESS format .MDB files. '* Input ASCII records must all be the same length ' (exceptions are written to the ERROR log) '* Input records must also be uniformly laid out, ' so that fields are located in the same position ' in each record. '* The .MDB file may or may not already exist. '* If it exists, you can choose to preserve other ' Tables in the MDB, and replace only the current ' Table... or replace the entire MDB file. '* requires Visual Basic 3 Professional Edition. ' You can make an EXE easily for each specific ' translation job '=============================================== 'Code modules: ' GENERAL.FRM ' the startup form, generalized routines only ' & Includes validation routines that validate ' most of the error-prone parameters you ' can set in SPECIFIC.BAS. ' GLOBALS.BAS ' database globals and a few code globals that ' should NOT need to be changed for each job ' SPECIFIC.BAS **CUSTOMIZE ONLY THIS FILE** ' isolates all the job specific pieces (hopefully) ' change the contents of each Sub, and ' the declarations, but don't change the names of ' the subroutines... see comments in SPECIFIC.BAS ' ARGV.BAS ' routines for parsing COMMAND (cmd line) ' using this allows some flexibility without having ' to recompile -- ' (only the default "input" and "output" ' fnames at Sept/93) ' (potentially everything in SPECIFIC.BAS could ' be fed in thru command line/data files) ' In a nutshell: SPECIFICS.BAS isolates ' all the items SPECIFIC to your file/job. ' You shouldn't have to change anything else but ' the routines in that file. These routines control ' the following: (see module comments) ' DATABASE file path ' REPLACEMODE variable ' - see the specific project .BAS file, ' SetupSpecifics routine ' - do we replace entire Database .mdb file? ' or just replace the entire Table in the .mdb? ' or just certain records in the Table? ' TABLE name ' FIELD parameters: ' - how to setup each field in the table ' - where to find each field in the input ' ASCII file. ' INDEX parameters ' DEFAULT PATHNAMES for the input ASCII file and ' the output MDB file, and for an Error log ' of Update errors Dim Msg gRunning = True 'for testing at cmdExit_click, cmdTranslate_click GlobalInit 'initialization, global.bas NL = Chr(13) & Chr(10) Form1.Show SetupSpecifics ' job specifics see in project .BAS Caption = App.Title CheckFields CheckIndexes ' decide which radio button for Replace mode pnlStatus = "collecting parameters...": DoEvents argvInit 'see if we are running with a command line ' if so, use the values from the command line ' instead of the programmed values If argc = 5 Then lblCurrInput = argv(1).Value lblCurrDatabase = argv(2).Value lblCurrTable = argv(3).Value localErrFileName = argv(4).Value ReplaceMode = argv(5).Value If ReplaceMode > 5 Or ReplaceMode < 0 Then Msg = "Command Line ReplaceMode parameter out of range." & NL Msg = Msg & "Resetting to 0." MsgBox Msg ReplaceMode = 0 End If Else lblCurrInput = gcDefInputName lblCurrDatabase = gcDefDbName lblCurrTable = gcTable localErrFileName = gcErrFileName End If 'check if error file name is okay before we start Logline "beginning run" & NL lblReplaceMode = ReplaceModes(ReplaceMode) If argc <> 0 And argc <> 5 Then MsgBox ("check number of cmd line args!") pnlStatus = "ready...": DoEvents gRunning = False 'for testing at cmdExit_click, cmdTranslate_click End Sub Sub LogError (BadLineCount, InMsg, InLineCount, InFileLine) Dim FileNum BadLineCount = BadLineCount + 1 FileNum = FreeFile Open localErrFileName For Append As FileNum Len = 300 'this slows things down if excessive errors... 'that's fine, user might notice and abort! Dim LogMsg LogMsg = Date & " " & Time & NL Select Case BadLineCount Case gbErrorLimit + 1 LogMsg = LogMsg & "over " & gbErrorLimit & "errors, no more logging" Print #FileNum, LogMsg Close FileNum Case Is <= gbErrorLimit LogMsg = LogMsg & InMsg LogMsg = LogMsg & Err & " " & Error & NL LogMsg = LogMsg & " BAD LINE, line " & InLineCount & NL LogMsg = LogMsg & " of input file " & lblCurrInput & NL LogMsg = LogMsg & InFileLine & NL LogMsg = LogMsg & "-----" & NL Print #FileNum, LogMsg Close FileNum Case Is > gbErrorLimit Close FileNum End Select End Sub Sub Logline (InMsg) Dim FileNum Dim Msg Dim LogMsg On Error GoTo BadErrLog FileNum = FreeFile If AscErrorFlag = False Then AscErrorFlag = True 'used to flag whether ErrFile 'is already assigned Open localErrFileName For Output As FileNum Len = 300 Else Open localErrFileName For Append As FileNum Len = 300 End If LogMsg = Date & " " & Time & NL LogMsg = LogMsg & InMsg LogMsg = LogMsg & "-----" & NL Print #FileNum, LogMsg Close FileNum Exit Sub BadErrLog: Msg = Err & " " & Error & NL Msg = Msg & "on opening log file." & NL Msg = Msg & "Probably: bad error log File Name." & NL Msg = Msg & "Check error log file name assigned in your code." & NL Msg = Msg & " or assigned in on the command line." & NL MsgBox Msg If Not gTabOut Is Nothing Then gTabOut.Close : thisDb.Close End End Sub Sub mnuEditInput_Click () Dim miSpot As Integer 'locate "\" char Dim miIndex As Integer 'locate "\" char pnlStatus = "collecting parameters...": DoEvents miSpot = 1 Do 'locate "\" char miIndex = miSpot + 1 miSpot = InStr(miIndex, lblCurrInput, "\") Loop Until miSpot = 0 cmdlg1.InitDir = Left$(lblCurrInput, miIndex - 2) cmdlg1.Filename = lblCurrInput cmdlg1.DialogTitle = "ASCII file to process" cmdlg1.Filter = "All Files (*.*)|*.*|Text files (*.txt)|*.txt" cmdlg1.Flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST cmdlg1.Action = 1 lblCurrInput = LCase$(cmdlg1.Filename) pnlStatus = "ready...": DoEvents End Sub Sub mnuEditMDB_Click () Dim miSpot As Integer 'locate "\" char Dim miIndex As Integer 'locate "\" char pnlStatus = "collecting parameters...": DoEvents miSpot = 1 Do 'locate "\" char miIndex = miSpot + 1 miSpot = InStr(miIndex, lblCurrDatabase, "\") Loop Until miSpot = 0 cmdlg1.InitDir = Left$(lblCurrDatabase, miIndex - 2) cmdlg1.Filename = lblCurrDatabase cmdlg1.DialogTitle = "Store in .MDB database file" cmdlg1.Filter = "MDB files (*.mdb)|*.mdb|All Files (*.*)|*.*" cmdlg1.Flags = OFN_HIDEREADONLY If ReplaceMode = 0 Then cmdlg1.Flags = cmdlg1.Flags Or OFN_CREATEPROMPT Or OFN_OVERWRITEPROMPT Else cmdlg1.Flags = cmdlg1.Flags Or OFN_FILEMUSTEXIST End If cmdlg1.Action = 2 lblCurrDatabase = LCase$(cmdlg1.Filename) pnlStatus = "ready...": DoEvents End Sub Sub mnuEditReplMode_Click () FrmReplaceMode.Show 1 End Sub Sub mnuEditTable_Click () On Error Resume Next frmSelTable.Show 1 pnlStatus = "ready...": DoEvents End Sub Sub mnuFileExit_Click () cmdExit_Click End Sub Sub mnuHelpAbout_Click () AboutFrm.Show 1 End Sub Sub mnuHelpContents_Click () Dim Msg Msg = "Creates .mdb files, tables, and/or records from ASCII input files." & NL Msg = Msg & "Read the file ASC2MDB.TXT for more information." & NL & NL Msg = Msg & "Tip: you can change the runtime defaults without changing " & NL Msg = Msg & " code or recompiling - use commandline options, see docs. " & NL & NL Msg = Msg & "Help on Replace Mode is under Edit, Replace Mode. " & NL & NL Msg = Msg & " 1993 Richard Curzon -- CIS 71371,2521 " & NL Msg = Msg & "all rights reserved - code may be freely used but" & NL Msg = Msg & " but may not be sold for profit in whole or in part." & NL MsgBox Msg End Sub Sub NewDatabase () Dim strOldTest As String Dim Msg 'kill old database file if any On Error GoTo NDError strOldTest = Dir(lblCurrDatabase) On Error GoTo 0 If Len(strOldTest) <> 0 Then pnlStatus = "deleting old database...": DoEvents Kill lblCurrDatabase End If 'create the new database file pnlStatus = "creating new database...": DoEvents Set thisDb = CreateDatabase(lblCurrDatabase, DB_LANG_GENERAL, 0) Exit Sub NDError: Msg = "Error:" & NL Msg = Msg & Err & " : " & Error & NL Msg = Msg & "In New Database creation" MsgBox Msg End End Sub Sub ReadyDatabase () Dim Msg If ReplaceMode = 0 Then pnlStatus = "creating new database...": DoEvents On Error GoTo MakeDbError NewDatabase On Error GoTo 0 Else pnlStatus = "opening existing database...": DoEvents On Error GoTo OpenDbError Set thisDb = OpenDatabase(lblCurrDatabase, True) On Error GoTo 0 End If Exit Sub MakeDbError: Msg = Err & " " & Error & NL Msg = Msg & " on trying to create the mdb file" MsgBox Msg End Exit Sub OpenDbError: Msg = Err & " " & Error & NL Msg = Msg & " on trying to open the mdb file" MsgBox Msg End End Sub Sub ReadyTable () Dim Msg Dim Ind As Integer, Looper As Integer On Error GoTo NoOldTable 'clear old table if it's there... If ReplaceMode <= 1 Then Dim NewTab As New TableDef Dim NewIdx As New Index Dim NewFld As New field If ReplaceMode = 1 Then Msg = "deleting existing table..." pnlStatus = Msg: DoEvents On Error Resume Next thisDb.TableDefs.Delete lblCurrTable On Error GoTo 0 End If Msg = "creating new table..." pnlStatus = Msg: DoEvents NewTab.Name = lblCurrTable ' Set the table name. ' Append Fields. Ind = UBound(gIOFld) Msg = "appending the fields..." pnlStatus = Msg: DoEvents For Looper = 1 To Ind ' Set properties for fields. NewFld.Name = gIOFld(Looper).dbName NewFld.Type = gIOFld(Looper).dbType NewFld.Size = gIOFld(Looper).dbSize NewTab.Fields.Append NewFld Set NewFld = Nothing Next Looper ' Append Indexes Ind = UBound(gIndexPtrn) Msg = "appending indexes..." pnlStatus = Msg: DoEvents For Looper = 1 To Ind ' Set properties for fields. NewIdx.Name = gIndexPtrn(Looper).Name NewIdx.Fields = gIndexPtrn(Looper).Fields NewIdx.Primary = gIndexPtrn(Looper).Primary NewIdx.Unique = gIndexPtrn(Looper).Unique NewTab.Indexes.Append NewIdx Set NewIdx = Nothing Next Looper ' Append Table creating all objects. Msg = "appending table, creating physical objects..." pnlStatus = Msg: DoEvents thisDb.TableDefs.Append NewTab End If Msg = "opening the table..." pnlStatus = Msg: DoEvents Set gTabOut = thisDb.OpenTable(lblCurrTable) On Error GoTo 0 Exit Sub NoOldTable: Msg = Msg & NL & "Error:" & NL Msg = Msg & Err & " : " & Error & NL Msg = Msg & "Trying to ready the database table... please check" MsgBox Msg End End Sub Sub ValidateMode345Key () Dim Msg On Error GoTo VMKeyError Select Case Mode345Key() Case 1 To UBound(gIOFld) Case Else Msg = "Invalid Mode345Key Function!" Error 32000 End Select On Error GoTo 0 Exit Sub VMKeyError: MsgBox Msg End End Sub