VERSION 5.00 Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "comctl32.ocx" Begin VB.Form frmMain BorderStyle = 1 'Fixed Single ClientHeight = 5550 ClientLeft = 165 ClientTop = 2715 ClientWidth = 8250 Icon = "main.frx":0000 LinkTopic = "Form1" LockControls = -1 'True MaxButton = 0 'False PaletteMode = 1 'UseZOrder ScaleHeight = 370 ScaleMode = 3 'Pixel ScaleWidth = 550 WhatsThisHelp = -1 'True Begin VB.CommandButton cmdDelete Caption = "del" Height = 345 Left = 6930 TabIndex = 9 Top = 1635 WhatsThisHelpID = 20080 Width = 1260 End Begin VB.Frame Frame2 Height = 75 Left = -30 TabIndex = 13 Top = -30 Width = 8355 End Begin VB.CommandButton cmbEdit Caption = "edit" Height = 345 Left = 5520 TabIndex = 8 Top = 1635 WhatsThisHelpID = 20070 Width = 1260 End Begin VB.CommandButton cmbadd Caption = "add" Height = 345 Left = 4080 TabIndex = 7 Top = 1635 WhatsThisHelpID = 20060 Width = 1275 End Begin VB.Frame FilterFrame Caption = "filter" Height = 1290 Left = 2925 TabIndex = 11 Top = 210 Width = 5250 Begin VB.TextBox txtsearch Height = 285 Left = 1650 MaxLength = 20 TabIndex = 5 Top = 780 WhatsThisHelpID = 20040 Width = 2175 End Begin VB.CommandButton cmbsearch Caption = "apply" Height = 345 Left = 3960 TabIndex = 6 Top = 720 WhatsThisHelpID = 20050 Width = 1185 End Begin VB.ComboBox combosearch Height = 315 ItemData = "main.frx":0ABA Left = 1650 List = "main.frx":0ABC Style = 2 'Dropdown List TabIndex = 3 Top = 330 WhatsThisHelpID = 20030 Width = 2175 End Begin VB.Label FilterLabel Alignment = 1 'Right Justify BackStyle = 0 'Transparent Caption = "by" Height = 255 Left = 120 TabIndex = 2 Top = 375 WhatsThisHelpID = 20030 Width = 1470 End Begin VB.Label SearchLabel Alignment = 1 'Right Justify BackStyle = 0 'Transparent Caption = "contain" Height = 255 Left = 120 TabIndex = 4 Top = 795 WhatsThisHelpID = 20040 Width = 1500 End End Begin ComctlLib.TreeView PBTree Height = 1185 Left = 120 TabIndex = 1 Top = 315 WhatsThisHelpID = 20000 Width = 2580 _ExtentX = 4551 _ExtentY = 2090 _Version = 327682 Indentation = 529 LabelEdit = 1 Sorted = -1 'True Style = 7 ImageList = "ImageList1" Appearance = 1 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty End Begin ComctlLib.ListView PopList Height = 3330 Left = 0 TabIndex = 12 Top = 2160 WhatsThisHelpID = 20020 Width = 8205 _ExtentX = 14473 _ExtentY = 5874 View = 3 LabelEdit = 1 LabelWrap = -1 'True HideSelection = 0 'False _Version = 327682 ForeColor = -2147483640 BackColor = -2147483643 Appearance = 1 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty NumItems = 6 BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7} Key = "" Object.Tag = "" Text = "pop" Object.Width = 2646 EndProperty BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7} Alignment = 1 Key = "" Object.Tag = "" Text = "ac" Object.Width = 1323 EndProperty BeginProperty ColumnHeader(3) {0713E8C7-850A-101B-AFC0-4210102A8DA7} Alignment = 1 Key = "" Object.Tag = "" Text = "num" Object.Width = 1720 EndProperty BeginProperty ColumnHeader(4) {0713E8C7-850A-101B-AFC0-4210102A8DA7} Alignment = 2 Key = "" Object.Tag = "" Text = "cntry" Object.Width = 1984 EndProperty BeginProperty ColumnHeader(5) {0713E8C7-850A-101B-AFC0-4210102A8DA7} Alignment = 2 Key = "" Object.Tag = "" Text = "reg" Object.Width = 1984 EndProperty BeginProperty ColumnHeader(6) {0713E8C7-850A-101B-AFC0-4210102A8DA7} Alignment = 2 Key = "" Object.Tag = "" Text = "stat" Object.Width = 1058 EndProperty End Begin VB.Label PBListLabel BackStyle = 0 'Transparent Caption = "pb" Height = 225 Left = 90 TabIndex = 0 Top = 90 WhatsThisHelpID = 20000 Width = 1695 End Begin ComctlLib.ImageList ImageList1 Left = 2760 Top = 675 _ExtentX = 1005 _ExtentY = 1005 BackColor = -2147483643 ImageWidth = 16 ImageHeight = 16 MaskColor = 12632256 _Version = 327682 BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7} NumListImages = 3 BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "main.frx":0ABE Key = "" EndProperty BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "main.frx":0DD8 Key = "" EndProperty BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "main.frx":10F2 Key = "" EndProperty EndProperty End Begin VB.Label PBLabel BackStyle = 0 'Transparent BorderStyle = 1 'Fixed Single Caption = " " Height = 315 Left = 75 TabIndex = 10 Top = 1665 WhatsThisHelpID = 20010 Width = 3720 End Begin VB.Menu file Caption = "&File--" Begin VB.Menu m_addpb Caption = "&New Phone Book...--" End Begin VB.Menu m_copypb Caption = "&Copy Phone Book...--" End Begin VB.Menu m_removepb Caption = "&Delete Phone Book--" End Begin VB.Menu div5 Caption = "-" End Begin VB.Menu m_printpops Caption = "&Print POP List--" End Begin VB.Menu m_viewlog Caption = "&View Log---" End Begin VB.Menu m_div Caption = "-" End Begin VB.Menu m_exit Caption = "E&xit--" End End Begin VB.Menu m_edit Caption = "&Edit--" Begin VB.Menu m_addpop Caption = "&Add POP...--" End Begin VB.Menu m_editpop Caption = "&Edit POP...--" End Begin VB.Menu m_delpop Caption = "&Delete POP--" End End Begin VB.Menu m_tools Caption = "&Tools--" Begin VB.Menu m_buildPhone Caption = "&Build Phone Book...--" End Begin VB.Menu viewChange Caption = "View &Phone Book Files...--" End Begin VB.Menu m_div1 Caption = "-" End Begin VB.Menu m_editflag Caption = "Edit &Flags...--" Visible = 0 'False End Begin VB.Menu m_editRegion Caption = "&Regions Editor...--" End Begin VB.Menu m_div2 Caption = "-" End Begin VB.Menu m_options Caption = "&Options...--" End End Begin VB.Menu help Caption = "&Help--" Begin VB.Menu contents Caption = "&Help Topics... -- " End Begin VB.Menu m_whatsthis Caption = "What's This? ---" End Begin VB.Menu m_div3 Caption = "-" End Begin VB.Menu about Caption = "&About Phone Book Administration--" End End End Attribute VB_Name = "frmMain" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Dim selection As Long Dim clickSelect As Integer Function cmdImportPBK(ByVal PBKFile As String, ByRef dbPB As Database) As Integer ' handles importing phone book file, in PBD format, meaning ' that adds, edits, deletes are allowed. based on POP ID. ' ' Add: , new data ' Edit: , new data ' Delete: , all zeros Dim intPBKFile As Integer Dim intX As Long Dim DelReturn As Integer, SaveRet As Integer Dim strSQL, strLine As String Dim varLine As Variant Dim CountryRS As Recordset Dim i As Integer Dim iLineCount As Integer 'ReDim varRecord(1) On Error GoTo ImportErr iLineCount = 0 If CheckPath(PBKFile) <> 0 Then cmdLogError 6076 cmdImportPBK = 0 Exit Function End If intPBKFile = FreeFile Open PBKFile For Input Access Read As #intPBKFile Do While Not EOF(intPBKFile) Line Input #intPBKFile, strLine If LOF(intPBKFile) = Len(strLine) Then ' check to see if there are any carriage return (Chr(13)) in the file cmdLogError 6100 cmdImportPBK = 0 Exit Function End If iLineCount = iLineCount + 1 If strLine <> "" Then varLine = SplitLine(strLine, ",") 'SplitLine should return 11 fields (0-10). 'DeletePOP and SavePOP expect the 'full 14. The extras are empty here. If Not IsNumeric(varLine(0)) Then cmdLogError 6086, " - " & LoadResString(6061) & "; " & LoadResString(6094) & " = " & iLineCount cmdImportPBK = 0 Exit Function Else If varLine(1) = "0" Then intX = varLine(0) DelReturn = DeletePOP(intX, dbPB) If DelReturn <> 0 Then cmdLogError 6078, " - " & LoadResString(6061) & " = " & CStr(DelReturn) End If Else intX = varLine(0) If UBound(varLine) <> 10 Then cmdLogError 6077, " - " & LoadResString(6084) & "; " & LoadResString(6061) & " = " & CStr(intX) cmdImportPBK = 0 'wrong # of fields Exit Function End If For i = 1 To 10 Select Case i Case 1 If Not IsNumeric(varLine(i)) Then cmdLogError 6086, " - " & gsCurrentPB & "; " & LoadResString(6061) & " = " & CStr(intX) & "; " & LoadResString(6062) & " = " & CStr(varLine(i)) cmdImportPBK = 0 Exit Function End If strSQL = "SELECT * from Country where CountryNumber = " & CStr(varLine(1)) Set CountryRS = dbPB.OpenRecordset(strSQL) If CountryRS.BOF And CountryRS.EOF Then cmdLogError 6090, " - " & gsCurrentPB & "; " & LoadResString(6061) & " = " & CStr(intX) & "; " & LoadResString(6062) & " = " & CStr(varLine(i)) cmdImportPBK = 0 Exit Function End If Case 2 If varLine(i) = "" Then varLine(i) = 0 End If If Not IsNumeric(varLine(i)) Then cmdLogError 6086, " - " & gsCurrentPB & "; " & LoadResString(6061) & " = " & CStr(intX) & "; " & LoadResString(6063) & " = " & CStr(varLine(i)) cmdImportPBK = 0 Exit Function End If strSQL = "SELECT * from region where RegionID = " & CStr(varLine(2)) Set GsysRgn = dbPB.OpenRecordset(strSQL) If GsysRgn.BOF And GsysRgn.EOF And CInt(varLine(i)) > 0 Then cmdLogError 6089, " - " & gsCurrentPB & "; " & LoadResString(6061) & " = " & CStr(intX) cmdImportPBK = 0 Exit Function End If Case 3 If Len(varLine(i)) > 30 Then cmdLogError 6085, " - " & gsCurrentPB & "; " & LoadResString(6061) & " = " & CStr(intX) & "; " & LoadResString(6064) & " = " & CStr(varLine(i)) cmdImportPBK = 0 Exit Function End If If varLine(i) = "" Then varLine(i) = " " End If Case 4 If Len(varLine(i)) > 10 Then cmdLogError 6085, " - " & gsCurrentPB & "; " & LoadResString(6061) & " = " & CStr(intX) & "; " & LoadResString(6065) & " = " & CStr(varLine(i)) cmdImportPBK = 0 Exit Function End If If varLine(i) = "" Then varLine(i) = " " End If Case 5 If Len(varLine(i)) > 40 Then cmdLogError 6085, " - " & gsCurrentPB & "; " & LoadResString(6061) & " = " & CStr(intX) & "; " & LoadResString(6066) & " = " & CStr(varLine(i)) cmdImportPBK = 0 Exit Function End If If varLine(i) = "" Then varLine(i) = " " End If Case 6 If Not IsNumeric(varLine(i)) And varLine(i) <> "" Then cmdLogError 6086, " - " & gsCurrentPB & "; " & LoadResString(6061) & " = " & CStr(intX) & "; " & LoadResString(6067) & " = " & CStr(varLine(i)) cmdImportPBK = 0 Exit Function End If If varLine(i) = "" Then varLine(i) = 0 End If Case 7 If Not IsNumeric(varLine(i)) And varLine(i) <> "" Then cmdLogError 6086, " - " & gsCurrentPB & "; " & LoadResString(6061) & " = " & CStr(intX) & "; " & LoadResString(6068) & " = " & CStr(varLine(i)) cmdImportPBK = 0 Exit Function End If If varLine(i) = "" Then varLine(i) = 0 End If Case 8 If Not IsNumeric(varLine(i)) And varLine(i) <> "" Then cmdLogError 6086, " - " & gsCurrentPB & "; " & LoadResString(6061) & " = " & CStr(intX) & "; " & LoadResString(6069) & " = " & CStr(varLine(i)) cmdImportPBK = 0 Exit Function End If If varLine(i) = "" Then varLine(i) = 0 End If Case 9 If Not IsNumeric(varLine(i)) And varLine(i) <> "" Then cmdLogError 6086, " - " & gsCurrentPB & "; " & LoadResString(6061) & " = " & CStr(intX) & "; " & LoadResString(6070) & " = " & CStr(varLine(i)) cmdImportPBK = 0 Exit Function End If If varLine(i) = "" Then varLine(i) = 0 End If End Select Next i If Len(varLine(4)) + Len(varLine(5)) > 35 Then cmdLogError 6091, " - " & gsCurrentPB & "; " & LoadResString(6061) & " = " & CStr(varLine(0)) cmdImportPBK = 0 Exit Function End If SaveRet = SavePOP(varLine, dbPB) If SaveRet <> 0 Then cmdLogError 6079, " - " & gsCurrentPB & "; " & LoadResString(6061) & " = " & CStr(SaveRet) cmdImportPBK = 0 Exit Function End If End If End If End If Loop Close #intPBKFile cmdLogSuccess 6096 On Error GoTo 0 Exit Function ImportErr: cmdImportPBK = 1 Exit Function End Function Function cmdImportRegions(ByVal RegionFile As String, ByRef dbPB As Database) As Integer ' this function imports a region file, format: ' , ' ' Add: , ' Edit: , ' Delete: , Dim intRegionFile As Integer 'Dim rsRegions As Recordset Dim strSQL, strLine As String Dim strRegionID, strRegionDesc As String Dim varLine As Variant Dim RS As Recordset Dim NewRgn As Recordset Dim PerformedDelete As Boolean Dim rsTempPop As Recordset, rsTempDelta As Recordset Dim i As Integer, deltnum As Integer Dim deltasql As String, popsql As String On Error GoTo RegionImport PerformedDelete = False If CheckPath(RegionFile) <> 0 Then cmdLogError 6076 cmdImportRegions = 0 Exit Function End If intRegionFile = FreeFile Open RegionFile For Input Access Read As #intRegionFile Do While Not EOF(intRegionFile) Line Input #intRegionFile, strLine If LOF(intRegionFile) = Len(strLine) Then ' check to see if there are any carriage return (Chr(13)) in the file cmdLogError 6100 cmdImportRegions = 0 Exit Function End If varLine = SplitLine(strLine, ",") strRegionID = varLine(0) strRegionDesc = varLine(1) If Trim(Str(Val(strRegionID))) = strRegionID Then ' check for integer ID value If strRegionDesc = "" Then Set GsysRgn = dbPB.OpenRecordset("SELECT * from region where RegionID = " & strRegionID, dbOpenSnapshot) strSQL = "DELETE FROM region WHERE RegionID = " & strRegionID dbPB.Execute strSQL popsql = "Select * from DialUpPort Where RegionID = " & strRegionID Set rsTempPop = dbPB.OpenRecordset(popsql, dbOpenDynaset) If Not (rsTempPop.BOF And rsTempPop.EOF) Then rsTempPop.MoveFirst Do Until rsTempPop.EOF rsTempPop.Edit rsTempPop!RegionID = 0 rsTempPop.Update If rsTempPop!status = 1 Then Set rsTempDelta = dbPB.OpenRecordset("Select * from Delta order by DeltaNum", dbOpenDynaset) If rsTempDelta.RecordCount = 0 Then deltnum = 1 Else rsTempDelta.MoveLast deltnum = rsTempDelta!deltanum If deltnum > 6 Then deltnum = deltnum - 1 End If End If For i = 1 To deltnum deltasql = "Select * from delta where DeltaNum = " & i & _ " AND AccessNumberId = '" & rsTempPop!AccessNumberId & "' " & _ " order by DeltaNum" Set rsTempDelta = dbPB.OpenRecordset(deltasql, dbOpenDynaset) If Not (rsTempDelta.BOF And rsTempDelta.EOF) Then rsTempDelta.Edit Else rsTempDelta.AddNew rsTempDelta!deltanum = i rsTempDelta!AccessNumberId = rsTempPop!AccessNumberId End If If rsTempPop!status = 1 Then rsTempDelta!CountryNumber = rsTempPop!CountryNumber rsTempDelta!AreaCode = rsTempPop!AreaCode rsTempDelta!AccessNumber = rsTempPop!AccessNumber rsTempDelta!MinimumSpeed = rsTempPop!MinimumSpeed rsTempDelta!MaximumSpeed = rsTempPop!MaximumSpeed rsTempDelta!RegionID = rsTempPop!RegionID rsTempDelta!CityName = rsTempPop!CityName rsTempDelta!ScriptID = rsTempPop!ScriptID rsTempDelta!Flags = rsTempPop!Flags rsTempDelta.Update End If Next i End If rsTempPop.MoveNext Loop End If PerformedDelete = True LogRegionDelete GsysRgn!RegionDesc, CStr(GsysRgn!RegionDesc) & ";" & CStr(GsysRgn!RegionID) Else Set GsysRgn = dbPB.OpenRecordset("SELECT * from region where RegionID = " & strRegionID, dbOpenSnapshot) If GsysRgn.EOF And GsysRgn.BOF Then strSQL = "Select * From region where RegionDesc="" " & strRegionDesc & " "" " Set RS = dbPB.OpenRecordset(strSQL, dbOpenSnapshot) If RS.EOF And RS.BOF Then strSQL = "INSERT INTO Region (RegionID, RegionDesc) VALUES (" & _ strRegionID & ", "" " & strRegionDesc & " "")" dbPB.Execute strSQL Set GsysRgn = dbPB.OpenRecordset("SELECT * from region where RegionID = " & strRegionID, dbOpenSnapshot) LogRegionAdd strRegionDesc, strRegionDesc & ";" & strRegionID Else cmdLogError 6088, " - " & gsCurrentPB & "; " & strRegionDesc cmdImportRegions = 0 Exit Function End If Else strSQL = "Select * From region where RegionDesc="" " & strRegionDesc & " "" " Set RS = dbPB.OpenRecordset(strSQL, dbOpenSnapshot) If (RS.EOF And RS.BOF) Then strSQL = "UPDATE region SET RegionDesc="" " & strRegionDesc & " "" " & _ " WHERE RegionID=" & strRegionID dbPB.Execute strSQL strSQL = "INSERT INTO Region (RegionID, RegionDesc) VALUES (" & _ strRegionID & ", "" " & strRegionDesc & " "")" dbPB.Execute strSQL Set NewRgn = dbPB.OpenRecordset("SELECT * from region where RegionID = " & strRegionID, dbOpenSnapshot) LogRegionEdit GsysRgn!RegionDesc, strRegionDesc & ";" & strRegionID Else If RS!RegionID = CInt(strRegionID) Then strSQL = "UPDATE region SET RegionDesc="" " & strRegionDesc & " "" " & _ " WHERE RegionID=" & strRegionID dbPB.Execute strSQL strSQL = "INSERT INTO Region (RegionID, RegionDesc) VALUES (" & _ strRegionID & ", "" " & strRegionDesc & " "")" dbPB.Execute strSQL Set NewRgn = dbPB.OpenRecordset("SELECT * from region where RegionID = " & strRegionID, dbOpenSnapshot) LogRegionEdit GsysRgn!RegionDesc, strRegionDesc & ";" & strRegionID Else cmdLogError 6088, " - " & gsCurrentPB & "; " & strRegionDesc cmdImportRegions = 0 Exit Function End If End If End If End If End If Loop If PerformedDelete Then If Not ReIndexRegions(dbPB) Then GoTo RegionImport End If Close #intRegionFile cmdLogSuccess 6097 cmdImportRegions = 0 On Error GoTo 0 Exit Function RegionImport: cmdLogError 6080, " - " & gsCurrentPB & "; " & LoadResString(6063) & " = " & strRegionID cmdImportRegions = 0 Exit Function End Function Function cmdLogSuccess(ErrorNum As Integer, Optional ErrorMsg As String) Dim intFile As Integer Dim strFile As String On Error GoTo LogErr gCLError = True intFile = FreeFile strFile = locPath & "import.log" Open strFile For Append As #intFile On Error GoTo 0 Print #intFile, Now & ", " & gsCurrentPB & ", " & LoadResString(ErrorNum) & ErrorMsg Close #intFile Exit Function LogErr: Exit Function End Function Function cmdPublish(ByVal PhoneBook As String, ByRef dbPB As Database) As Integer Dim rsConfig As Recordset Dim Pbversion As Integer Dim config As Recordset Dim deltnum, vercheck As Integer Dim sql1, sql2 As String Dim vernumsql, mastersql, deltasql As String Dim deltanum As Integer, vernum As Integer, previousver As Integer Dim filesaveas As String, i As Integer, verfile As String Dim fullddffile As String, dtaddffile As String Dim sShort, sLong As String Dim strTemp As String Dim strRelPath As String Dim strSPCfile As String Dim strPVKfile As String Dim filelen As Long Dim bNewVersion As Boolean Dim result As Integer Dim strucFname As OFSTRUCT Dim strSearchFile As String Dim strRelativePath As String Dim configure As Recordset Dim intX As Integer, previous As Integer Dim vertualpath As String Dim strSource As String, strDestination As String Dim webpostdir As String Dim webpostdir1 As String Dim strBaseFile As String Dim strPBVirPath As String Dim strPBName As String Dim postpath As Variant Dim myValue As Long Dim intAuthCount As Integer Dim bErr As Boolean Dim bTriedRepair As Boolean Dim intVersion As Integer Dim intRC As Integer Dim URL Set GsysVer = dbPB.OpenRecordset("Select * from PhoneBookVersions order by version", dbOpenDynaset) Set GsysDelta = dbPB.OpenRecordset("Select * from Delta order by DeltaNum", dbOpenDynaset) Set rsConfig = dbPB.OpenRecordset("select * from Configuration where Index = 1", dbOpenSnapshot) Set gsyspb = dbPB gsCurrentPB = PhoneBook If GsysVer.RecordCount = 0 Then Pbversion = 1 Else GsysVer.MoveLast Pbversion = GsysVer!version + 1 End If gBuildDir = rsConfig!PBbuildDir If IsEmpty(gBuildDir) Or gBuildDir = "" Or IsNull(gBuildDir) Then gBuildDir = locPath & gsCurrentPB End If URL = rsConfig!URL If CheckPath(gBuildDir) <> 0 Then cmdLogError 6087 Exit Function End If If IsNull(URL) Then cmdLogError 6087 Exit Function End If rsConfig.Close On Error GoTo ErrTrapFile gBuildDir = Trim(gBuildDir) If Right(gBuildDir, 1) = "\" Then gBuildDir = Left(gBuildDir, Len(gBuildDir) - 1) End If strRelPath = gBuildDir & "\" Set config = dbPB.OpenRecordset("select * from Configuration where Index = 1", dbOpenDynaset) config.MoveLast If GsysDelta.RecordCount = 0 Then deltnum = 1 Else GsysDelta.MoveLast deltnum = GsysDelta!deltanum vercheck = GsysDelta!NewVersion bNewVersion = False If Not IsNull(config!NewVersion) Then If config!NewVersion = 1 Then bNewVersion = True End If End If If vercheck = 1 And Not bNewVersion Then cmdLogError (6038) Exit Function End If End If vernum = Pbversion mastersql = "SELECT * from DialUpPort where Status = '1' order by AccessNumberId" Set GsysNDial = dbPB.OpenRecordset(mastersql, dbOpenSnapshot) If GsysNDial.RecordCount = 0 Then 'master phone file Set GsysNDial = Nothing cmdLogError (6039) Exit Function Else sLong = strRelPath filesaveas = sLong & vernum & "Full.pbk" verfile = sLong & vernum & ".VER" Load frmNewVersion masterOutfile filesaveas, GsysNDial FileCopy filesaveas, sLong & gsCurrentPB & ".pbk" frmNewVersion.VersionOutFile verfile, vernum frmNewVersion.outfullddf sLong, vernum & "Full.pbk", Str(vernum) frmNewVersion.WriteRegionFile sLong & gsCurrentPB & ".pbr" If Left(Trim(locPath), 2) <> "\\" Then ChDrive locPath End If ChDir locPath WaitForApp "full.bat" & " " & _ gQuote & sLong & vernum & "Full.cab" & gQuote & " " & _ gQuote & sLong & vernum & "Full.ddf" & gQuote End If 'Check for existence of full.cab strSearchFile = sLong & vernum & "Full.cab" result = OpenFile(strSearchFile, strucFname, OF_EXIST) If result = -1 Then cmdLogError (6075) Exit Function End If If vernum > 1 Then deltasql = "Select * from delta order by DeltaNum" Set GsysNDelta = dbPB.OpenRecordset(deltasql, dbOpenSnapshot) If GsysNDelta.RecordCount <> 0 Then GsysNDelta.MoveLast deltanum = GsysNDelta!deltanum End If previousver = vernum - deltanum + 1 For i = 2 To deltanum deltasql = "Select * from delta where NewVersion <> 1 and DeltaNum = " & i & " order by AccessNumberId" Set GsysNDelta = dbPB.OpenRecordset(deltasql, dbOpenSnapshot) filesaveas = sLong & vernum & "DTA" & previousver & ".pbk" dtaddffile = vernum & "DELTA" & previousver & ".ddf" deltaoutfile filesaveas, GsysNDelta frmNewVersion.outdtaddf sLong, dtaddffile, filesaveas, Str(vernum) WaitForApp "dta.bat" & " " & _ gQuote & sLong & vernum & "DELTA" & previousver & ".cab" & gQuote & " " & _ gQuote & sLong & vernum & "DELTA" & previousver & ".ddf" & gQuote previousver = previousver + 1 Next i% End If Set GsysNDial = Nothing Set GsysNDelta = Nothing On Error GoTo ErrTrapPost bTriedRepair = False intVersion = Val(Pbversion) deltanum = GetDeltaCount(intVersion) postpath = locPath + "pbserver.mdb" strPBName = gsCurrentPB strPBVirPath = ReplaceChars(strPBName, " ", "_") Set configure = dbPB.OpenRecordset("select * from Configuration where Index = 1", dbOpenDynaset) intRC = frmNewVersion.UpdateHkeeper(postpath, gsCurrentPB, intVersion, strPBVirPath) ' here's the webpost stuff webpostdir = gBuildDir & "\" & intVersion & "post" If CheckPath(webpostdir) = 0 Then ' dir name in use - rename old myValue = Hour(Now) * 10000 + Minute(Now) * 100 + Second(Now) Name webpostdir As webpostdir & "_old_" & myValue End If MkDir webpostdir FileCopy locPath & "pbserver.mdb", webpostdir & "\pbserver.mdb" ' copy the CABs FileCopy gBuildDir & "\" & intVersion & "full.cab", webpostdir & "\" & intVersion & "full.cab" previous = intVersion - deltanum For intX = 1 To deltanum strSource = gBuildDir & "\" & intVersion & "delta" & previous & ".cab" strDestination = webpostdir & "\" & intVersion & "delta" & previous & ".cab" FileCopy strSource, strDestination previous = previous + 1 Next intX intRC = PostFiles(configure!URL, configure!ServerUID, configure!ServerPWD, intVersion, webpostdir, strPBVirPath) If intRC = 1 Then bErr = True Else bErr = False If Not bErr Then GsysVer.AddNew GsysVer!version = intVersion GsysVer!CreationDate = Date GsysVer.Update Set GsysDelta = dbPB.OpenRecordset("SELECT * FROM delta ORDER BY DeltaNum", dbOpenDynaset) GsysDelta.MoveLast deltanum = GsysDelta!deltanum If deltanum < 6 Then GsysDelta.AddNew GsysDelta!deltanum = deltanum + 1 GsysDelta!NewVersion = 1 GsysDelta.Update Else sql1 = "DELETE FROM delta WHERE DeltaNum = 1" dbPB.Execute sql1, dbFailOnError sql2 = "UPDATE delta SET DeltaNum = DeltaNum - 1" dbPB.Execute sql2, dbFailOnError Set GsysDelta = dbPB.OpenRecordset("Select * from Delta order by DeltaNum", dbOpenDynaset) GsysDelta.AddNew GsysDelta!deltanum = 6 GsysDelta!NewVersion = 1 GsysDelta.Update End If Set GsysDelta = Nothing End If If Not bErr Then cmdLogSuccess 6098 configure.Edit configure!NewVersion = 0 configure.Update LogPublish intVersion End If configure.Close Unload frmNewVersion Exit Function ErrTrapFile: Set GsysNDial = Nothing Set GsysNDelta = Nothing Select Case Err.Number Case 3022 cmdLogError (6040) Case 75 cmdLogError (6041) Case Else cmdLogError (6041) End Select Exit Function ErrTrapPost: Set GsysDelta = Nothing cmdLogError (6043) Exit Function End Function Public Function PostFiles(ByVal Host As String, ByVal UID As String, ByVal PWD As String, ByVal version As Integer, ByVal PostDir As String, ByVal VirPath As String) As Integer ' ================================================================================= ' this function handles the ' POST to the PB Server ' ' Arguments: host, uid, pwd, version, postdir, virpath ' Returns: 0 = success ' 1 = fail ' ' history: Created April '97 Paul Kreemer ' ' ================================================================================= Const VROOT As String = "PBSDATA" Const DIR_DB As String = "DATABASE" Const LOCALFILE As String = "pbserver.mdb" Const REMOTEFILE As String = "newpb.mdb" Dim intAuthCount As Byte Dim intX As Integer Dim strBaseFile As String ' setup the OCX and check for connection With frmNewVersion.inetOCX .URL = "ftp://" & Host .UserName = UID .Password = PWD .Protocol = icFTP .AccessType = icUseDefault .RequestTimeout = 60 End With On Error GoTo DirError frmNewVersion.inetOCX.Execute , "CD /" & VROOT & "/" & VirPath frmNewVersion.PostWait ' If the directory doesn't exist then create it If frmNewVersion.inetOCX.ResponseCode = 12003 Then frmNewVersion.inetOCX.Execute , "CD /" & VROOT frmNewVersion.PostWait If frmNewVersion.inetOCX.ResponseCode = 12003 Then cmdLogError 6060, " " & Host & " " & frmNewVersion.inetOCX.ResponseInfo PostFiles = 1 Exit Function End If frmNewVersion.inetOCX.Execute , "MKDIR " & VirPath frmNewVersion.PostWait If frmNewVersion.inetOCX.ResponseCode = 12003 Then cmdLogError 6060, " " & Host & " " & frmNewVersion.inetOCX.ResponseInfo PostFiles = 1 Exit Function End If frmNewVersion.inetOCX.Execute , "CD /" & VROOT & "/" & VirPath frmNewVersion.PostWait If frmNewVersion.inetOCX.ResponseCode = 12003 Then cmdLogError 6060, " " & Host & " " & frmNewVersion.inetOCX.ResponseInfo PostFiles = 1 Exit Function End If End If ' full CAB frmNewVersion.inetOCX.Execute , "PUT " & gQuote & PostDir & "\" & version & "full.cab" & gQuote & " " & _ version & "full.cab" frmNewVersion.PostWait If frmNewVersion.inetOCX.ResponseCode = 12003 Then cmdLogError 6060, " " & Host & " " & frmNewVersion.inetOCX.ResponseInfo PostFiles = 1 Exit Function End If ' Delta CABs strBaseFile = version & "delta" For intX = version - GetDeltaCount(version) To version - 1 frmNewVersion.inetOCX.Execute , "PUT " & gQuote & PostDir & "\" & strBaseFile & intX & ".cab" & gQuote & " " & _ strBaseFile & intX & ".cab" frmNewVersion.PostWait Next If frmNewVersion.inetOCX.ResponseCode = 12003 Then cmdLogError 6060, " " & Host & " " & frmNewVersion.inetOCX.ResponseInfo PostFiles = 1 Exit Function End If ' go to db dir frmNewVersion.inetOCX.Execute , "CD /" & VROOT & "/" & DIR_DB frmNewVersion.PostWait If frmNewVersion.inetOCX.ResponseCode = 12003 Then cmdLogError 6060, " " & Host & " " & frmNewVersion.inetOCX.ResponseInfo PostFiles = 1 Exit Function End If 'PBSERVER.mdb (NewPB.mdb) frmNewVersion.inetOCX.Execute , "PUT " & gQuote & PostDir & "\" & LOCALFILE & gQuote & " " & REMOTEFILE frmNewVersion.PostWait If frmNewVersion.inetOCX.ResponseCode = 12003 Then cmdLogError 6060, " " & Host & " " & frmNewVersion.inetOCX.ResponseInfo PostFiles = 1 Exit Function End If ' NewPB.txt frmNewVersion.inetOCX.Execute , "PUT " & gQuote & gBuildDir & "\" & version & ".ver" & gQuote & " newpb.txt" frmNewVersion.PostWait If frmNewVersion.inetOCX.ResponseCode = 12003 Then cmdLogError 6060, " " & Host & " " & frmNewVersion.inetOCX.ResponseInfo PostFiles = 1 Exit Function End If frmNewVersion.inetOCX.Execute , "QUIT" PostFiles = 0 Exit Function DirError: Select Case Err.Number Case 35750 To 35755, 35761 'Unable to contact cmdLogError 6042 PostFiles = 1 Case 35756 To 35760 'Connection Timed Out cmdLogError 6043 PostFiles = 1 Case Else cmdLogError 6043 PostFiles = 1 End Select End Function Function EndApp() On Error Resume Next OSWinHelp Me.hWnd, App.HelpFile, HelpConstants.cdlHelpQuit, 0 'DBEngine.Idle 'dbFreeLocks GsysRgn.Close Set GsysRgn = Nothing GsysCty.Close Set GsysCty = Nothing GsysDial.Close Set GsysDial = Nothing GsysVer.Close Set GsysVer = Nothing GsysDelta.Close Set GsysDelta = Nothing GsysNRgn.Close Set GsysNRgn = Nothing GsysNCty.Close Set GsysNCty = Nothing GsysNDial.Close Set GsysNDial = Nothing GsysNVer.Close Set GsysNVer = Nothing GsysNDelta.Close Set GsysNDelta = Nothing temp.Close Set temp = Nothing gsyspb.Close Set gsyspb = Nothing Gsyspbpost.Close Set Gsyspbpost = Nothing MyWorkspace.Close Set MyWorkspace = Nothing End End Function Function FillPBTree() As Integer Dim itmX As Node Dim varRegKeys As Variant Dim intX As Integer Dim strPB As String Dim strPath As String On Error GoTo FillpbTreeErr PBTree.Nodes.Clear DoEvents ' get pb list from registry varRegKeys = GetINISetting("Phonebooks", "") 'all settings If TypeName(varRegKeys) = Empty Then FillPBTree = 1 Exit Function End If intX = 0 Do While varRegKeys(intX, 0) <> Empty strPB = Trim(varRegKeys(intX, 1)) If strPB <> "" And Not IsNull(strPB) Then strPath = locPath & strPB If CheckPath(strPath) = 0 Then 'verify files Set itmX = PBTree.Nodes.Add() With itmX .Image = 2 .Text = varRegKeys(intX, 0) .Key = varRegKeys(intX, 0) End With End If End If intX = intX + 1 Loop PBTree.Sorted = True HighlightPB gsCurrentPB Exit Function FillpbTreeErr: FillPBTree = 1 Exit Function 'Set itmX = PBTree.Nodes.Add() 'With itmX ' .Image = 1 ' .Text = "Big New Phone Book" ' .key = itmX.Text 'End With 'Set child = PBTree.Nodes.Add(itmX.Index, tvwChild, , "Current Release", 3) 'Set child = PBTree.Nodes.Add(itmX.Index, tvwChild, , "Previous Releases", 3) 'Set subChild = PBTree.Nodes.Add(child, tvwChild, , "2", 3) 'Set subChild = PBTree.Nodes.Add(child, tvwChild, , "1", 3) End Function Function FillPOPList() As Integer Dim sqlstm, strTemp As String Dim intRow, intX As Integer Dim itmX As ListItem On Error GoTo ErrTrap If gsCurrentPB = "" Then PopList.ListItems.Clear Exit Function End If Me.Enabled = False Screen.MousePointer = 11 sqlstm = "SELECT DISTINCTROW DialUpPort.CityName, Country.CountryName, Region.RegionDesc, DialUpPort.RegionID, DialUpPort.AreaCode, DialUpPort.AccessNumber, DialUpPort.Status, DialUpPort.AccessNumberId " & _ "FROM (Country INNER JOIN DialUpPort ON Country.CountryNumber = DialUpPort.CountryNumber) LEFT JOIN Region ON DialUpPort.RegionId = Region.RegionId " Select Case combosearch.ItemData(combosearch.ListIndex) Case 0, -1 '"all pops" ' nothing Case 1 '"access number" sqlstm = sqlstm & " WHERE AccessNumber like '*" & txtsearch.Text & "*" & "'" Case 2 '"area code" sqlstm = sqlstm & " WHERE AreaCode like '*" & txtsearch.Text & "*" & "'" Case 3 '"country" sqlstm = sqlstm & " WHERE CountryName like '*" & txtsearch.Text & "*" & "'" Case 4 '"pop name" sqlstm = sqlstm & " WHERE CityName like '*" & txtsearch.Text & "*" & "'" Case 5 '"region" sqlstm = sqlstm & " WHERE RegionDesc like '*" & txtsearch.Text & "*" & "'" Case 6 '"status" strTemp = "" For intX = 0 To 1 If InStr(LCase(gStatusText(intX)), Trim(LCase(txtsearch.Text))) <> 0 Then If strTemp = "" Then strTemp = Trim(Str(intX)) Else strTemp = "*" End If End If Next If strTemp = "" Then PopList.ListItems.Clear Me.Enabled = True Screen.MousePointer = 0 Exit Function End If sqlstm = sqlstm & " WHERE Status like '" & strTemp & "'" End Select sqlstm = sqlstm & ";" Set GsysNDial = gsyspb.OpenRecordset(sqlstm, dbOpenSnapshot) If GsysNDial.BOF = False Then GsysNDial.MoveLast If GsysNDial.RecordCount > 50 Then RefreshPBLabel "loading" PopList.ListItems.Clear PopList.Sorted = False GsysNDial.MoveFirst Do While Not GsysNDial.EOF Set itmX = PopList.ListItems.Add() With itmX .Text = GsysNDial!CityName .SubItems(1) = GsysNDial!AreaCode .SubItems(2) = GsysNDial!AccessNumber .SubItems(3) = GsysNDial!countryname intX = GsysNDial!RegionID Select Case intX Case 0, -1 .SubItems(4) = gRegionText(intX) Case Else .SubItems(4) = GsysNDial!RegionDesc End Select .SubItems(5) = gStatusText(GsysNDial!status) strTemp = "Key:" & GsysNDial!AccessNumberId .Key = strTemp End With If GsysNDial.AbsolutePosition Mod 300 = 0 Then DoEvents GsysNDial.MoveNext Loop Else PopList.ListItems.Clear End If PopList.Sorted = True Me.Enabled = True Screen.MousePointer = 0 Exit Function ErrTrap: Me.Enabled = True FillPOPList = 1 Screen.MousePointer = 0 Exit Function End Function Function HighlightPB(strPBName As String) As Integer ' highlight pb in tree view control ' and clear the other nodes image setting. Dim intX As Integer For intX = 1 To PBTree.Nodes.Count PBTree.Nodes(intX).Image = 2 If PBTree.Nodes(intX).Key = strPBName Then PBTree.Nodes(intX).Image = 1 PBTree.Nodes(intX).Selected = True PBTree.Nodes(intX).EnsureVisible End If Next RefreshPBLabel "" End Function Function LoadMainRes() As Integer Dim cRef As Integer Dim intX As Integer On Error GoTo ResErr cRef = 3010 'global status text array gStatusText(0) = LoadResString(4061) gStatusText(1) = LoadResString(4060) 'gRegionText(-1) = LoadResString(4063) gRegionText(0) = LoadResString(4063) PBListLabel.Caption = LoadResString(cRef + 0) FilterFrame.Caption = LoadResString(cRef + 1) FilterLabel.Caption = LoadResString(cRef + 2) SearchLabel.Caption = LoadResString(cRef + 3) cmbsearch.Caption = LoadResString(cRef + 4) cmbadd.Caption = LoadResString(cRef + 5) cmbEdit.Caption = LoadResString(cRef + 6) cmdDelete.Caption = LoadResString(cRef + 7) 'column headers For intX = 1 To 6 PopList.ColumnHeaders(intX).Text = LoadResString(cRef + 7 + intX) Next ' pop search list For intX = 0 To 6 combosearch.AddItem LoadResString(cRef + 15 + intX) combosearch.ItemData(combosearch.NewIndex) = intX Next combosearch.Text = LoadResString(cRef + 15) 'menus file.Caption = LoadResString(cRef + 22) m_edit.Caption = LoadResString(cRef + 23) m_tools.Caption = LoadResString(cRef + 24) help.Caption = LoadResString(cRef + 25) m_addpb.Caption = LoadResString(cRef + 26) m_copypb.Caption = LoadResString(cRef + 27) m_removepb.Caption = LoadResString(cRef + 28) m_exit.Caption = LoadResString(cRef + 29) m_addpop.Caption = LoadResString(cRef + 30) m_editpop.Caption = LoadResString(cRef + 31) m_delpop.Caption = LoadResString(cRef + 32) m_buildPhone.Caption = LoadResString(cRef + 33) viewChange.Caption = LoadResString(cRef + 34) m_editRegion.Caption = LoadResString(cRef + 36) m_options.Caption = LoadResString(cRef + 37) contents.Caption = LoadResString(cRef + 38) about.Caption = LoadResString(cRef + 39) m_printpops.Caption = LoadResString(cRef + 40) m_viewlog.Caption = LoadResString(cRef + 41) m_whatsthis.Caption = LoadResString(cRef + 42) ' set fonts SetFonts Me PopList.Font.Charset = gfnt.Charset PopList.Font.Name = gfnt.Name PopList.Font.Size = gfnt.Size LoadMainRes = 0 On Error GoTo 0 Exit Function ResErr: LoadMainRes = 1 Exit Function End Function Function RefreshPBLabel(ByVal Action As String) As Integer On Error GoTo LabelErr If gsCurrentPB <> "" Then Select Case Action Case "loading" PBLabel.Caption = " " & LoadResString(3061) & " " & gsCurrentPB Case Else PBLabel.Caption = " " & gsCurrentPB & " - [" & combosearch.Text & "]" End Select Else PBLabel.Caption = " " & LoadResString(3060) & " " End If DoEvents On Error GoTo 0 Exit Function LabelErr: Exit Function End Function Function RemovePB() As Integer ' get the open phonebook and ask if it should ' be removed. clean out pbserver.mdb Dim varRegKeys As Variant Dim intRC As Integer On Error GoTo delErr If gsCurrentPB = "" Then Exit Function intRC = MsgBox(LoadResString(4066) & Chr(13) & Chr(13) & gsCurrentPB & Chr(13) & Chr(13) & LoadResString(4088), vbQuestion + 4 + 256) If intRC = 6 Then DBEngine.Idle gsyspb.Close Set gsyspb = Nothing Kill gsCurrentPBPath ' delete entry and flush out INI edits OSWritePrivateProfileString "Phonebooks", gsCurrentPB, vbNullString, locPath & gsRegAppTitle & ".ini" OSWritePrivateProfileString vbNullString, vbNullString, vbNullString, locPath & gsRegAppTitle & ".ini" ' clear hkeeper Set Gsyspbpost = DBEngine.Workspaces(0).OpenDatabase(locPath + "pbserver.mdb") DBEngine.Idle Gsyspbpost.Execute "DELETE from Phonebooks WHERE ISPid = (select ISPid from ISPs where Description ='" & gsCurrentPB & "')", dbFailOnError Gsyspbpost.Execute "DELETE from ISPs WHERE Description = '" & gsCurrentPB & "'", dbFailOnError Gsyspbpost.Close Set Gsyspbpost = Nothing If SetCurrentPB("") = 0 Then PopList.ListItems.Clear FillPBTree RefreshButtons End If End If Exit Function delErr: Exit Function End Function Function RunCommandLine() As Integer ' this function manages the no-GUI, command-line ' execution of PBAdmin.exe Dim ArgArray As Variant Dim strArg As String Dim bImport, bImportPBK, bImportRegions, bPublish, bNewDB As Boolean Dim bHelp As Boolean Dim bSetOptions As Boolean Dim strPhoneBook, strPBPath As String Dim strPBKFile, strRegionFile As String Dim strNewDB As String Dim strURL As String Dim strUser As String Dim strPassword As String Dim intX, intRC As Integer Dim dbPB As Database Dim RetVal As Integer On Error GoTo RunErr ArgArray = GetCommandLine If UBound(ArgArray) = 0 Then RunCommandLine = 0 Exit Function End If 'MsgBox str(Asc(ArgArray(0))) 'If ArgArray(0) = "" Then ' RunCommandLine = 0 ' Exit Function 'End If strPhoneBook = "" intX = 1 Do While intX <= UBound(ArgArray) Select Case ArgArray(intX) Case "/?" ' list switches bHelp = True Case "/I" intX = intX + 1 strPhoneBook = ArgArray(intX) bImport = True Case "/P" intX = intX + 1 strPBKFile = ArgArray(intX) bImportPBK = True Case "/R" intX = intX + 1 strRegionFile = ArgArray(intX) bImportRegions = True Case "/B" intX = intX + 1 strPhoneBook = ArgArray(intX) bPublish = True Case "/N" intX = intX + 1 strNewDB = ArgArray(intX) bNewDB = True Case "/O" intX = intX + 1 strPhoneBook = ArgArray(intX) intX = intX + 1 strURL = ArgArray(intX) intX = intX + 1 strUser = ArgArray(intX) intX = intX + 1 strPassword = ArgArray(intX) bSetOptions = True Case Else bHelp = True End Select intX = intX + 1 Loop If bHelp Then MsgBox LoadResString(6057), vbInformation End End If If strPhoneBook <> "" Then ' open database If Right(strPhoneBook, 4) = ".mdb" Then strPhoneBook = Left(strPhoneBook, Len(strPhoneBook) - 4) End If strPBPath = GetLocalPath & strPhoneBook If CheckPath(strPBPath) <> 0 Then cmdLogError 6082, " - " & strPhoneBook End End If gsCurrentPB = strPhoneBook On Error Resume Next ConvertDatabaseIfNeeded DBEngine.Workspaces(0), strPBPath & ".mdb", dbDriverNoPrompt, False Set dbPB = DBEngine.Workspaces(0).OpenDatabase(strPBPath & ".mdb", dbDriverNoPrompt, False, DBPassword) ' Cannot open same object twice & close it twice. Otherwise you ' will get a runtime error. v-vijayb 6/11/99 Set gsyspb = dbPB 'Set gsyspb = DBEngine.Workspaces(0).OpenDatabase(strPBPath & ".mdb") If Err.Number <> 0 Then Select Case Err.Number Case 3051 cmdLogError 6027, " - " & gsCurrentPB End Case 3343 cmdLogError 6028, " - " & gsCurrentPB End Case 3045 cmdLogError 6029, " - " & gsCurrentPB End Case Else cmdLogError 6030, " - " & gsCurrentPB End End Select End If On Error GoTo RunErr 'import regions If bImportRegions Then If cmdImportRegions(strRegionFile, dbPB) <> 0 Then dbPB.Close cmdLogError 6080 End End If End If 'import pbk/pbd If bImportPBK Then If cmdImportPBK(strPBKFile, dbPB) <> 0 Then 'error dbPB.Close cmdLogError 6080 End End If End If 'publish: UpdateHkeeper If bPublish Then If cmdPublish(strPhoneBook, dbPB) <> 0 Then dbPB.Close cmdLogError 6081 End 'error End If End If If bSetOptions Then SetOptions strURL, strUser, strPassword End If dbPB.Close 'gsyspb.Close Else ' Create a new PB If bNewDB Then CreatePB (strNewDB) Else If bImportPBK Or bImportRegions Then cmdLogError 6092 Else cmdLogError 6093 End If End If End If End Exit Function RunErr: cmdLogError 6081 End End Function Function SetCurrentPB(ByVal strPBName As String) As Integer ' all phonebooks are in app directory, for now. ' the registry layout does allow storing them anywhere, with ' any name, excepting pbserver.mdb and hkeeper.mdb. Dim strPBFile, strPath As String Dim rsTest As Recordset On Error GoTo SetCurrentPBErr If strPBName = gsCurrentPB Then Exit Function ElseIf strPBName = "" Then strPBFile = "" Else strPBFile = GetINISetting("Phonebooks", strPBName) If CheckPath(locPath & strPBFile) <> 0 Then strPBFile = "" End If End If 'close old Phone Book gsCurrentPBPath = "" gsCurrentPB = "" FillPOPList DBEngine.Idle Set MyWorkspace = Nothing If strPBFile = "" And strPBName <> "" Then ' bad pb, delete entry On Error GoTo DelSettingErr OSWritePrivateProfileString "Phonebooks", strPBName, vbNullString, locPath & gsRegAppTitle & ".ini" OSWritePrivateProfileString vbNullString, vbNullString, vbNullString, locPath & gsRegAppTitle & ".ini" strPBName = "" strPath = "" MsgBox LoadResString(6026), vbExclamation FillPBTree Else ' looking good Set MyWorkspace = Workspaces(0) strPath = locPath & strPBFile On Error GoTo BadFileErr ConvertDatabaseIfNeeded MyWorkspace, strPath, dbDriverNoPrompt, False Set gsyspb = MyWorkspace.OpenDatabase(strPath, dbDriverNoPrompt, False, DBPassword) 'exclusive Set rsTest = gsyspb.OpenRecordset("select * from Configuration", dbOpenSnapshot) rsTest.Close Set rsTest = Nothing DBEngine.Idle 'dbFreeLocks 'UpgradePB End If On Error GoTo SetCurrentPBErr gsCurrentPBPath = strPath gsCurrentPB = strPBName If FillPOPList <> 0 Then MsgBox LoadResString(6030), vbExclamation gsCurrentPB = "" SetCurrentPB = 1 End If OSWritePrivateProfileString "General", "LastPhonebookUsed", gsCurrentPB, locPath & gsRegAppTitle & ".ini" OSWritePrivateProfileString vbNullString, vbNullString, vbNullString, locPath & gsRegAppTitle & ".ini" HighlightPB strPBName RefreshButtons selection = 0 updateFound = 0 On Error GoTo 0 Exit Function SetCurrentPBErr: SetCurrentPB = 1 Exit Function BadFileErr: If strPBName <> "" Then Select Case Err.Number Case 3051 MsgBox LoadResString(6027) & _ Chr(13) & Chr(13) & strPath, vbInformation Case 3343 MsgBox LoadResString(6028) & _ Chr(13) & Chr(13) & strPath, vbExclamation Case 3045 MsgBox LoadResString(6029) & Chr(13) & Chr(13) & Err.Description, vbInformation Case Else MsgBox LoadResString(6030) & Chr(13) & Chr(13) & Err.Description, vbExclamation End Select End If strPBName = "" strPath = "" Resume Next DelSettingErr: Resume Next End Function Function Startup() As Integer ' handle all app init here Dim intRC As Integer Dim varPhonebooks, varLastPB As Variant Dim bTriedReg As Boolean On Error GoTo StartupErr ' set global values gsRegAppTitle = "PBAdmin" gsCurrentPB = "-" gQuote = Chr(34) gCLError = False GetFont gfnt LoadMainRes 'load labels DoEvents ' Check for required files GetLocalPath On Error GoTo HelpFileErr App.HelpFile = locPath & gsRegAppTitle & ".hlp" HTMLHelpFile = GetWinDir & "\help\cps_ops.chm" On Error GoTo HkeeperErr Set Gsyspbpost = DBEngine.Workspaces(0).OpenDatabase(locPath & "pbserver.mdb") Gsyspbpost.Close 'DBEngine.Idle On Error GoTo Empty_PBErr Set Gsyspbpost = DBEngine.Workspaces(0).OpenDatabase(locPath & "Empty_PB.mdb") Gsyspbpost.Close App.title = LoadResString(1001) 'cmd line processing On Error GoTo CmdErr RunCommandLine On Error GoTo StartupErr frmMain.Show 'kludge to set the font property of these two controls PBTree.Font.Charset = gfnt.Charset PBTree.Font.Name = gfnt.Name PBTree.Font.Size = gfnt.Size PBLabel.Font.Charset = gfnt.Charset PBLabel.Font.Name = gfnt.Name PBLabel.Font.Size = gfnt.Size intRC = FillPBTree 'get last used phone book and make it current varLastPB = GetINISetting("General", "LastPhonebookUsed") If IsNull(varLastPB) Then ' fallback to first pb in list varPhonebooks = GetINISetting("Phonebooks", "") If TypeName(varPhonebooks) <> Empty And Not IsNull(varPhonebooks) Then varLastPB = varPhonebooks(0, 0) Else varLastPB = "" End If End If PBLabel.Visible = True ' set misc Me.Caption = App.title SetCurrentPB varLastPB RefreshButtons On Error GoTo 0 Exit Function StartupErr: Startup = 1 Exit Function HelpFileErr: MsgBox LoadResString(6031), vbExclamation App.HelpFile = "" Resume Next HkeeperErr: ' problem w/ hkeeper.mdb. this is the first DAO test so first try to ' reregister the dao dll. if that fails then display message and end. If CheckPath(locPath & "pbserver.mdb") <> 0 Or bTriedReg Then MsgBox LoadResString(6032) & Chr(13) & locPath & "pbserver.mdb", vbCritical End Else Dim strDAOPath As String Dim lngValue As Long 'strDAOPath = RegGetValue("Software\Microsoft\Shared Tools\DAO", "Path") 'strDAOPath = GetMyShortPath(strDAOPath) bTriedReg = True If Not (IsNull(strDAOPath) Or strDAOPath = "") Then WaitForApp "regsvr32 /s " & strDAOPath Set Gsyspbpost = DBEngine.Workspaces(0).OpenDatabase(locPath & "pbserver.mdb") Resume Next Else GoTo HkeeperErr End If End If Empty_PBErr: MsgBox LoadResString(6032) & Chr(13) & locPath & "Empty_PB.mdb", vbCritical End CmdErr: ' error processing commandline End End Function Function GetCommandLine(Optional MaxArgs) 'Declare variables. Dim C, CmdLine, CmdLnLen, InArg, i, NumArgs 'See if MaxArgs was provided. If IsMissing(MaxArgs) Then MaxArgs = 10 'Make array of the correct size. ReDim ArgArray(MaxArgs) NumArgs = 0: InArg = False 'Get command line arguments. CmdLine = Command() CmdLnLen = Len(CmdLine) 'Go thru command line one character 'at a time. For i = 1 To CmdLnLen C = Mid(CmdLine, i, 1) 'Test for space or tab. If (C <> " " And C <> vbTab) Then 'Neither space nor tab. 'Test if already in argument. If Not InArg Then 'New argument begins. 'Test for too many arguments. If NumArgs = MaxArgs Then Exit For NumArgs = NumArgs + 1 InArg = True End If 'Concatenate character to current argument. ArgArray(NumArgs) = ArgArray(NumArgs) & C Else 'Found a space or tab. 'Set InArg flag to False. InArg = False End If Next i 'Resize array just enough to hold arguments. ReDim Preserve ArgArray(NumArgs) 'Return Array in Function name. GetCommandLine = ArgArray() End Function Private Sub about_Click() frmabout.Show vbModal End Sub Private Sub cmbsearch_GotFocus() cmbEdit.Enabled = False cmdDelete.Enabled = False m_editpop.Enabled = False m_delpop.Enabled = False End Sub Private Sub combosearch_GotFocus() cmbEdit.Enabled = False cmdDelete.Enabled = False m_editpop.Enabled = False m_delpop.Enabled = False End Sub Private Sub Form_KeyPress(KeyAscii As Integer) CheckChar KeyAscii End Sub Private Sub Form_Unload(Cancel As Integer) EndApp End Sub Private Sub m_addpop_Click() cmbadd_Click End Sub Private Sub m_buildPhone_Click() Screen.MousePointer = 11 frmNewVersion.Show vbModal RefreshButtons End Sub Private Sub cmbadd_Click() 'Dim strReturn As String 'Dim lngBuffer As Long 'Dim lngRC As Long 'strReturn = Space(50) 'lngBuffer = Len(strReturn) 'lngRC = WNetGetConnection(txtsearch.Text, strReturn, lngBuffer) 'MsgBox strReturn & " id:" & lngRC, , "wnetgetconnection" 'Exit sub frmPopInsert.Show vbModal RefreshButtons End Sub Private Sub cmbEdit_Click() If updateFound = 0 Then Exit Sub frmupdate.Show vbModal End Sub Private Sub cmbsearch_Click() Screen.MousePointer = 11 cmbsearch.Enabled = False updateFound = 0 ' clear the pop-selected variables selection = 0 If FillPOPList = 0 Then RefreshPBLabel "" RefreshButtons End If cmbsearch.Enabled = True Screen.MousePointer = 0 End Sub Private Sub cmdDelete_Click() Dim response As Integer, deltnum As Integer Dim Message As String, title As String, dialogtype As Long Dim i As Integer, deltasql As String, deltafind As Integer Dim deletecheck As Recordset Dim statuscheck As Integer On Error GoTo ErrTrap Set GsysDial = gsyspb.OpenRecordset("select * from Dialupport where accessnumberId = " & selection, dbOpenSnapshot) If GsysDial.EOF And GsysDial.BOF Then Exit Sub If updateFound = GsysDial!AccessNumberId Then Message = LoadResString(6033) dialogtype = vbYesNo + vbQuestion + vbDefaultButton2 response = MsgBox(Message, dialogtype) If response = 6 Then Screen.MousePointer = 11 statuscheck = 0 If GsysDial!status = "1" Then statuscheck = 1 End If gsyspb.Execute "DELETE from DialUpPort where AccessNumberId = " & updateFound If statuscheck = 1 Then 'insert the delta table Set GsysDelta = gsyspb.OpenRecordset("Select * from Delta order by DeltaNum", dbOpenDynaset) If GsysDelta.RecordCount = 0 Then deltnum = 1 Else GsysDelta.MoveLast deltnum = GsysDelta!deltanum If deltnum > 6 Then deltnum = deltnum - 1 End If End If For i = 1 To deltnum deltasql = "Select * from delta where DeltaNum = " & i% & _ " AND AccessNumberId = '" & updateFound & "' " & _ " order by DeltaNum" Set GsysDelta = gsyspb.OpenRecordset(deltasql, dbOpenDynaset) If Not (GsysDelta.BOF And GsysDelta.EOF) Then GsysDelta.Edit Else GsysDelta.AddNew GsysDelta!deltanum = i% GsysDelta!AccessNumberId = updateFound End If GsysDelta!CountryNumber = 0 GsysDelta!AreaCode = 0 GsysDelta!AccessNumber = 0 GsysDelta!MinimumSpeed = 0 GsysDelta!MaximumSpeed = 0 GsysDelta!RegionID = 0 GsysDelta!CityName = "0" GsysDelta!ScriptID = "0" GsysDelta!Flags = 0 GsysDelta.Update Next i% End If Set deletecheck = gsyspb.OpenRecordset("DialUpPort", dbOpenSnapshot) If deletecheck.RecordCount = 0 Then gsyspb.Execute "DELETE from PhoneBookVersions" gsyspb.Execute "DELETE from delta" End If Else Exit Sub End If LogPOPDelete GsysDial GsysDial.Close Set GsysDial = Nothing PopList.ListItems.Remove "Key:" & updateFound selection = 0 updateFound = 0 RefreshButtons frmMain.PopList.SetFocus Screen.MousePointer = 0 End If On Error GoTo 0 Exit Sub ErrTrap: Screen.MousePointer = 0 MsgBox LoadResString(6056) & Chr(13) & Chr(13) & Err.Description, vbExclamation Exit Sub End Sub Private Sub combosearch_Click() If combosearch.Text = LoadResString(3025) Then txtsearch.Enabled = False SearchLabel.Enabled = False Else txtsearch.Enabled = True SearchLabel.Enabled = True End If RefreshButtons End Sub Private Sub contents_Click() 'OSWinHelp Me.hWnd, App.HelpFile, HelpConstants.cdlHelpContents, 0 HtmlHelp Me.hWnd, HTMLHelpFile & ">proc4", HH_DISPLAY_TOPIC, CStr("cps_topnode.htm") End Sub Private Sub Form_Load() Dim cRef As Integer On Error GoTo LoadErr 'If App.PrevInstance Then ' MsgBox LoadResString(6035), vbExclamation ' End 'End If Screen.MousePointer = 11 CenterForm Me, Screen If Startup <> 0 Then 'If 0 = 1 Then Screen.MousePointer = 0 MsgBox LoadResString(6036), vbCritical End End If Screen.MousePointer = 0 On Error GoTo 0 Exit Sub LoadErr: Screen.MousePointer = 0 Exit Sub End Sub Private Sub m_addpb_Click() Dim strNewPB As String Dim itmX As Node On Error GoTo AddPBErr frmNewPB.Show vbModal strNewPB = frmNewPB.strPB Unload frmNewPB If strNewPB <> "" Then SetCurrentPB strNewPB FillPBTree 'frmcab.Show vbModal ' show options page End If Exit Sub AddPBErr: Exit Sub End Sub Private Sub m_copypb_Click() Dim intRC As Integer Dim strNewPB As String Dim itmX As Node On Error GoTo CopyPBErr frmCopyPB.Show vbModal strNewPB = frmCopyPB.strPB Unload frmCopyPB If strNewPB <> "" Then SetCurrentPB strNewPB FillPBTree 'frmcab.Show vbModal End If Exit Sub CopyPBErr: Exit Sub End Sub Private Sub m_delpop_Click() cmdDelete_Click End Sub Private Sub m_editpop_Click() cmbEdit_Click End Sub Private Sub m_editRegion_Click() Screen.MousePointer = 11 frmLoadRegion.Show vbModal End Sub Private Sub m_exit_Click() EndApp End Sub Private Sub m_printpops_Click() On Error GoTo ErrTrap Screen.MousePointer = 13 m_printpops.Enabled = False ' popup print screen and let it print Load frmPrinting frmPrinting.JobType = 2 frmPrinting.Show vbModal m_printpops.Enabled = True Screen.MousePointer = 0 Exit Sub ErrTrap: m_printpops.Enabled = True Screen.MousePointer = 0 Exit Sub End Sub Private Sub m_removepb_Click() RemovePB End Sub Private Sub m_options_Click() Screen.MousePointer = 11 frmcab.Show vbModal End Sub Private Sub m_viewlog_Click() Dim strFile As String Dim intFile As Integer On Error GoTo LogErr strFile = locPath & gsCurrentPB & "\" & gsCurrentPB & ".log" If CheckPath(strFile) <> 0 Then MakeLogFile gsCurrentPB End If Shell "notepad " & strFile, vbNormalFocus On Error GoTo 0 Exit Sub LogErr: MsgBox LoadResString(6053), vbExclamation Exit Sub End Sub Private Sub m_whatsthis_Click() frmMain.WhatsThisMode End Sub Private Sub PBTree_DblClick() If gsCurrentPB <> "" Then frmcab.Show vbModal End If End Sub Private Sub PBTree_GotFocus() cmbEdit.Enabled = False cmdDelete.Enabled = False m_editpop.Enabled = False m_delpop.Enabled = False End Sub Private Sub PBTree_NodeClick(ByVal ClickedNode As Node) ' this routine just sets the current pb based ' on the clicked node. ' we're currently only displaying pb nodes so ' it can be very simple. Dim strNewPB As String Dim intRC As Integer On Error Resume Next Screen.MousePointer = 11 ' change current phonebook strNewPB = ClickedNode.Key If strNewPB = "" Then Screen.MousePointer = 0 Exit Sub End If If SetCurrentPB(strNewPB) <> 0 Then Screen.MousePointer = 0 Exit Sub End If selection = 0 updateFound = 0 RefreshButtons Screen.MousePointer = 0 On Error GoTo 0 End Sub Private Sub PopList_ColumnClick(ByVal ColumnHeader As ColumnHeader) On Error Resume Next Screen.MousePointer = 11 DoEvents PopList.SortKey = ColumnHeader.index - 1 PopList.Sorted = True Screen.MousePointer = 0 On Error GoTo 0 End Sub Private Sub PopList_DblClick() 'selection = Val(Right$(PopList.SelectedItem.Key, Len(PopList.SelectedItem.Key) - 4)) 'updateFound = selection If selection <> 0 And Not IsNull(selection) Then cmbEdit_Click End If End Sub Private Sub PopList_GotFocus() If gsCurrentPB <> "" Then cmbEdit.Enabled = True cmdDelete.Enabled = True m_editpop.Enabled = True m_delpop.Enabled = True End If End Sub Private Sub PopList_ItemClick(ByVal Item As ListItem) On Error GoTo ItemErr ' here's our baby selection = Val(Right$(Item.Key, Len(Item.Key) - 4)) updateFound = selection RefreshButtons On Error GoTo 0 Exit Sub ItemErr: Exit Sub End Sub Private Sub txtsearch_Change() cmbsearch.Default = True RefreshButtons End Sub Private Sub txtsearch_GotFocus() SelectText txtsearch cmbEdit.Enabled = False cmdDelete.Enabled = False m_editpop.Enabled = False m_delpop.Enabled = False End Sub Function RefreshButtons() As Integer ' this routine attempts to handle all of the main ' screen ui - buttons and menus. Dim bSetting As Boolean Dim rsTemp As Recordset cmbsearch.Enabled = Not txtsearch = "" Or combosearch.Text = LoadResString(3025) If Not cmbsearch.Enabled Then cmbsearch.Default = False End If 'based on PB selected If gsCurrentPB <> "" Then bSetting = True cmbadd.Enabled = bSetting m_addpop.Enabled = bSetting m_copypb.Enabled = bSetting m_removepb.Enabled = bSetting m_viewlog.Enabled = bSetting m_buildPhone.Enabled = bSetting viewChange.Enabled = bSetting m_editRegion.Enabled = bSetting m_options.Enabled = bSetting FilterFrame.Enabled = bSetting 'pop list print If PopList.ListItems.Count = 0 Then m_printpops.Enabled = False Else m_printpops.Enabled = True End If ' handle regions editing 'If gsCurrentPBPath <> "" Then ' Set rsTemp = GsysPb.OpenRecordset("PhonebookVersions", dbOpenSnapshot) ' If rsTemp.BOF And rsTemp.EOF Then 'enable ' m_editRegion.Enabled = True ' Else 'disable region edits ' m_editRegion.Enabled = False ' End If ' rsTemp.Close 'End If ' based on pop selected If selection > 0 Then bSetting = True Else bSetting = False End If cmbEdit.Enabled = bSetting cmdDelete.Enabled = bSetting m_editpop.Enabled = bSetting m_delpop.Enabled = bSetting Else bSetting = False cmbadd.Enabled = bSetting cmbEdit.Enabled = bSetting cmdDelete.Enabled = bSetting m_viewlog.Enabled = bSetting m_addpop.Enabled = bSetting m_editpop.Enabled = bSetting m_delpop.Enabled = bSetting m_copypb.Enabled = bSetting m_removepb.Enabled = bSetting m_printpops.Enabled = bSetting m_buildPhone.Enabled = bSetting viewChange.Enabled = bSetting m_editflag.Enabled = bSetting m_editRegion.Enabled = bSetting m_options.Enabled = bSetting FilterFrame.Enabled = bSetting End If End Function Private Sub viewChange_Click() Dim masterSet As Recordset Dim sql As String On Error GoTo ErrTrap Screen.MousePointer = 11 sql = "Select AccessNumberId as [Access ID], AreaCode as [Area Code], AccessNumber as [Access number], Status, MinimumSpeed as [Min speed], Maximumspeed as [Max speed], CityName as [POP name], CountryNumber as [Country Number], ServiceType as [Service type], RegionId as [Region ID], ScriptID as [Dial-up connection], SupportNumber as [Flags for input], flipFactor as [Flip factor], Flags , Comments from DialUpPort order by AccessNumberId" Set masterSet = gsyspb.OpenRecordset(sql, dbOpenSnapshot) If masterSet.EOF And masterSet.BOF Then masterSet.Close Screen.MousePointer = 0 MsgBox LoadResString(6034), vbExclamation Exit Sub End If masterSet.Close frmdelta.Show vbModal Exit Sub ErrTrap: Screen.MousePointer = 0 MsgBox LoadResString(6056) & Chr(13) & Chr(13) & Err.Description, vbExclamation Exit Sub End Sub ' This function returns the path to the Windows directory as a ' string. Function GetWinDir() As String Dim lpbuffer As String * 255 Dim Length As Long Length = apiGetWindowsDirectory(lpbuffer, Len(lpbuffer)) GetWinDir = Left(lpbuffer, Length) End Function