'//+---------------------------------------------------------------------------- '// '// File: newver.frm '// '// Module: pbadmin.exe '// '// Synopsis: The dialog for publishing phonebooks in PBA '// '// Copyright (c) 1997-1999 Microsoft Corporation '// '// Author: quintinb Created Header 09/02/99 '// '//+---------------------------------------------------------------------------- VERSION 5.00 Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX" Object = "{48E59290-9880-11CF-9754-00AA00C00908}#1.0#0"; "MSINET.OCX" Begin VB.Form frmNewVersion BorderStyle = 3 'Fixed Dialog Caption = "build Phone Book" ClientHeight = 4440 ClientLeft = 405 ClientTop = 1500 ClientWidth = 6795 Icon = "newver.frx":0000 KeyPreview = -1 'True LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False PaletteMode = 1 'UseZOrder ScaleHeight = 4440 ScaleWidth = 6795 ShowInTaskbar = 0 'False WhatsThisButton = -1 'True WhatsThisHelp = -1 'True Begin InetCtlsObjects.Inet inetOCX Left = 1860 Top = 3030 _ExtentX = 1005 _ExtentY = 1005 _Version = 393216 Protocol = 2 RemotePort = 21 URL = "ftp://" End Begin VB.CommandButton cmbOptions Caption = "&options..." Height = 375 Left = 5160 TabIndex = 2 Top = 780 WhatsThisHelpID = 14010 Width = 1410 End Begin VB.Frame Frame2 Height = 30 Left = 225 TabIndex = 15 Top = 3750 Width = 6405 End Begin VB.Frame Frame1 Height = 30 Left = 210 TabIndex = 14 Top = 2325 Width = 6405 End Begin VB.CommandButton BrowseButton Caption = "brwse" Height = 375 Left = 5175 TabIndex = 5 Top = 1890 WhatsThisHelpID = 14030 Width = 1425 End Begin VB.TextBox DirText Alignment = 1 'Right Justify Height = 330 Left = 3000 MaxLength = 255 TabIndex = 4 Top = 1905 WhatsThisHelpID = 14020 Width = 1980 End Begin VB.CommandButton Command3 Caption = "post" Height = 375 Left = 270 TabIndex = 1 Top = 3255 WhatsThisHelpID = 14070 Width = 1185 End Begin VB.CommandButton cmbCancel Cancel = -1 'True Caption = "clos" Height = 375 Left = 5445 TabIndex = 6 Top = 3930 WhatsThisHelpID = 10020 Width = 1170 End Begin VB.CommandButton Command1 Caption = "&create" Height = 375 Left = 210 TabIndex = 0 Top = 1860 WhatsThisHelpID = 14060 Width = 1200 End Begin ComctlLib.ProgressBar ProgressBar1 Height = 270 Left = 225 TabIndex = 16 Top = 4035 Visible = 0 'False Width = 2985 _ExtentX = 5265 _ExtentY = 476 _Version = 327682 Appearance = 1 End Begin VB.Label ServerNameText BackStyle = 0 'Transparent BorderStyle = 1 'Fixed Single Height = 315 Left = 3420 TabIndex = 13 Top = 3270 WhatsThisHelpID = 14040 Width = 3180 End Begin VB.Label ServerLabel BackStyle = 0 'Transparent Caption = "server" Height = 240 Left = 3435 TabIndex = 12 Top = 3030 WhatsThisHelpID = 14040 Width = 3075 End Begin VB.Label CreateLabel BackStyle = 0 'Transparent Caption = "create a new phone book release." Height = 1575 Left = 180 TabIndex = 11 Top = 90 Width = 2655 End Begin VB.Label txtver Alignment = 1 'Right Justify BackStyle = 0 'Transparent BorderStyle = 1 'Fixed Single BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 315 Left = 3000 TabIndex = 10 Top = 810 WhatsThisHelpID = 14000 Width = 990 End Begin VB.Label DirLabel Caption = "release directory:" Height = 255 Left = 3030 TabIndex = 3 Top = 1680 WhatsThisHelpID = 14020 Width = 2385 End Begin VB.Label PostLabel BackStyle = 0 'Transparent Caption = "post the new release to the Phone Book Server." Height = 720 Left = 210 TabIndex = 7 Top = 2490 Width = 2325 End Begin VB.Label lbldate BorderStyle = 1 'Fixed Single ForeColor = &H00000000& Height = 285 Left = 2490 TabIndex = 9 Top = 1950 Visible = 0 'False Width = 390 End Begin VB.Label ReleaseLabel BackStyle = 0 'Transparent Caption = "new release:" Height = 225 Left = 3000 TabIndex = 8 Top = 480 WhatsThisHelpID = 14000 Width = 2595 End End Attribute VB_Name = "frmNewVersion" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Dim bAuthFinished As Boolean Function ChangeProgressBar(AddValue As Integer) As Integer On Error GoTo ProgressErr If (ProgressBar1.Value + AddValue) <= 100 And (ProgressBar1.Value + AddValue) >= 0 Then ProgressBar1.Value = ProgressBar1.Value + AddValue Else If (ProgressBar1.Value + AddValue) < 0 Then ProgressBar1.Value = 0 Else ProgressBar1.Value = 100 End If End If Exit Function ProgressErr: ChangeProgressBar = 1 Exit Function End Function Function LoadBuildRes() Dim cRef As Integer On Error GoTo LoadErr cRef = 5000 Me.Caption = LoadResString(cRef + 191) & " " & gsCurrentPB Command1.Caption = LoadResString(cRef + 192) Command3.Caption = LoadResString(cRef + 193) cmbOptions.Caption = LoadResString(cRef + 194) BrowseButton.Caption = LoadResString(1009) CreateLabel.Caption = LoadResString(cRef + 195) PostLabel.Caption = LoadResString(cRef + 196) ReleaseLabel.Caption = LoadResString(cRef + 197) DirLabel.Caption = LoadResString(cRef + 198) ServerLabel.Caption = LoadResString(cRef + 199) 'statuslabel.Caption = LoadResString(cRef + 200) cmbCancel.Caption = LoadResString(1005) ' set fonts SetFonts Me On Error GoTo 0 Exit Function LoadErr: Exit Function End Function Public Function outdtaddf(ByVal path As String, ByVal dtafile As String, ByVal PBKFile As String, ByVal version As String) Dim intFile As Integer Dim strRegFile As String Dim strPBKFile As String Dim strVerFile As String On Error GoTo DTAErr strRegFile = gQuote & path & gsCurrentPB & ".pbr" & gQuote strPBKFile = gQuote & PBKFile & gQuote version = Trim(version) strVerFile = gQuote & path & version & ".ver" & gQuote intFile = FreeFile Open path & dtafile For Output As #intFile Print #intFile, strRegFile; " "; gsCurrentPB & ".pbr" Print #intFile, strPBKFile; " "; "pbupdate.pbd" Print #intFile, strVerFile; " "; "pbupdate.ver" Close #intFile On Error GoTo 0 Exit Function DTAErr: Exit Function End Function Public Function outfullddf(ByVal path As String, ByVal fullfile As String, ByVal version As String) Dim strPBKFile As String Dim strRegFile As String Dim strVerFile As String Dim intFile As Integer On Error GoTo fullddfErr strPBKFile = gQuote & path & fullfile & gQuote strRegFile = gQuote & path & gsCurrentPB & ".pbr" & gQuote version = Trim(version) strVerFile = gQuote & path & version & ".ver" & gQuote 'If CheckPath(strINFfile) <> 0 Then ' MakeFullINF gsCurrentPB 'End If intFile = FreeFile Open path & version & "Full.ddf" For Output As #intFile Print #intFile, strRegFile; " "; gsCurrentPB & ".pbr" Print #intFile, strPBKFile; " "; gsCurrentPB & ".pbk" Print #intFile, strVerFile; " "; "pbupdate.ver" Close #intFile On Error GoTo 0 Exit Function fullddfErr: 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 inetOCX .URL = "ftp://" & Host .UserName = UID .Password = PWD .Protocol = icFTP .AccessType = icUseDefault .RequestTimeout = 60 End With On Error GoTo DirError inetOCX.Execute , "CD /" & VROOT & "/" & VirPath PostWait ' If the directory doesn't exist then create it If inetOCX.ResponseCode = 12003 Then inetOCX.Execute , "CD /" & VROOT PostWait If inetOCX.ResponseCode = 12003 Then MsgBox LoadResString(6060) & " " & Host & vbCrLf & inetOCX.ResponseInfo, 0 PostFiles = 1 Exit Function End If inetOCX.Execute , "MKDIR " & VirPath PostWait If inetOCX.ResponseCode = 12003 Then MsgBox LoadResString(6060) & " " & Host & vbCrLf & inetOCX.ResponseInfo, 0 PostFiles = 1 Exit Function End If inetOCX.Execute , "CD /" & VROOT & "/" & VirPath PostWait If inetOCX.ResponseCode = 12003 Then MsgBox LoadResString(6060) & " " & Host & vbCrLf & inetOCX.ResponseInfo, 0 PostFiles = 1 Exit Function End If End If ' full CAB inetOCX.Execute , "PUT " & gQuote & PostDir & "\" & version & "full.cab" & gQuote & " " & _ version & "full.cab" ChangeProgressBar 10 PostWait If inetOCX.ResponseCode = 0 Then ' Delta CABs strBaseFile = version & "delta" For intX = version - GetDeltaCount(version) To version - 1 inetOCX.Execute , "PUT " & gQuote & PostDir & "\" & strBaseFile & intX & ".cab" & gQuote & " " & _ strBaseFile & intX & ".cab" ChangeProgressBar 10 PostWait If inetOCX.ResponseCode <> 0 Then GoTo ineterr Next ' go to db dir inetOCX.Execute , "CD /" & VROOT & "/" & DIR_DB PostWait If inetOCX.ResponseCode <> 0 Then GoTo ineterr 'PBSERVER.mdb (NewPB.mdb) inetOCX.Execute , "PUT " & gQuote & PostDir & "\" & LOCALFILE & gQuote & " " & REMOTEFILE PostWait If inetOCX.ResponseCode <> 0 Then GoTo ineterr ChangeProgressBar 10 ' NewPB.txt inetOCX.Execute , "PUT " & gQuote & DirText.Text & "\" & version & ".ver" & gQuote & " newpb.txt" PostWait ChangeProgressBar 5 Else GoTo ineterr End If inetOCX.Execute , "QUIT" PostFiles = 0 Exit Function ineterr: MsgBox LoadResString(6101) & " " & inetOCX.ResponseInfo, 0 inetOCX.Execute , "QUIT" PostFiles = 1 Exit Function DirError: inetOCX.Execute , "QUIT" Select Case Err.Number Case 35750 To 35755, 35761 'Unable to contact MsgBox LoadResString(6042), vbExclamation + vbOKOnly PostFiles = 1 Case 35756 To 35760 'Connection Timed Out MsgBox LoadResString(6043), vbExclamation + vbOKOnly PostFiles = 1 Case Else MsgBox LoadResString(6043), vbExclamation + vbOKOnly PostFiles = 1 End Select End Function Public Function UpdateHkeeper(ByVal DBPath As String, ByVal PhoneBook As String, ByVal version As Integer, ByVal VirPath As String) As Integer '========================================================================== ' handle all updates of HKEEPER.MDB relating to posting a phone book. ' ' Arguments: ' Returns: 0 = success ' 1 = failure ' ' History: Created Apr 24 '97 Paul Kreemer '========================================================================== Dim rsOS, rsTemp As Recordset Dim intISPid As Integer Dim intPrevious As Integer Dim intX As Integer Dim strPath As String On Error GoTo UpdateErr Set Gsyspbpost = DBEngine.Workspaces(0).OpenDatabase(DBPath) Set rsOS = gsyspb.OpenRecordset("OSTypes") Set rsTemp = Gsyspbpost.OpenRecordset("select * from ISPs where Description like '" & PhoneBook & "'", dbOpenDynaset) If rsTemp.EOF And rsTemp.BOF Then 'insert row w/ new id Set rsTemp = Gsyspbpost.OpenRecordset("select max(ISPid) as maxID from ISPs", dbOpenSnapshot) If IsNull(rsTemp!maxID) Then intISPid = 1 Else intISPid = rsTemp!maxID + 1 End If Set rsTemp = Gsyspbpost.OpenRecordset("select * from ISPs", dbOpenDynaset) rsTemp.AddNew rsTemp!Description = PhoneBook rsTemp!ISPid = intISPid rsTemp.Update Else ' use existing ID rsTemp.MoveFirst intISPid = rsTemp!ISPid End If rsTemp.Close Gsyspbpost.Execute "DELETE from Phonebooks WHERE ISPid = " & Str(intISPid), dbFailOnError ChangeProgressBar 10 rsOS.MoveFirst While Not rsOS.EOF intPrevious = version - GetDeltaCount(version) For intX = 1 To GetDeltaCount(version) strPath = "/PBSDATA/" & VirPath & "/" & version & "DELTA" & intPrevious & ".cab" Gsyspbpost.Execute "INSERT INTO Phonebooks " & _ "(ISPid, Version, LCID, OS, Arch, VirtualPath) " & _ "VALUES ( " & Str$(intISPid) & "," & _ intPrevious & "," & _ "0," & _ Str$(rsOS!OSType) & ", " & _ "0, " & _ "'" & strPath & "')", dbFailOnError intPrevious = intPrevious + 1 Next intX strPath = "/PBSDATA/" & VirPath & "/" & version & "full.cab" Gsyspbpost.Execute "INSERT INTO Phonebooks " & _ "(ISPid, Version, LCID, OS, Arch, VirtualPath) " & _ "VALUES ( " & Str$(intISPid) & "," & _ version & "," & _ "0," & _ Str$(rsOS!OSType) & ", " & _ "0, " & _ "'" & strPath & "')", dbFailOnError rsOS.MoveNext Wend DBEngine.Idle rsOS.Close Gsyspbpost.Close Exit Function UpdateErr: UpdateHkeeper = 1 End Function Public Function VersionOutFile(file As String, vernum As Integer) Dim intFile As Integer intFile = FreeFile Open file For Output As #intFile Print #intFile, Trim(vernum) Close #intFile End Function Public Function PostWait() Do Until Not inetOCX.StillExecuting DoEvents Loop End Function Public Function WriteRegionFile(file As String) As Integer Dim ds As Recordset Dim intFile As Integer On Error GoTo WriteErr intFile = FreeFile Set ds = gsyspb.OpenRecordset("SELECT RegionDesc FROM Region order by RegionId", dbOpenSnapshot) Open file For Output As #intFile If ds.EOF And ds.BOF Then Print #intFile, "0" Else ds.MoveLast ds.MoveFirst Print #intFile, ds.RecordCount While Not ds.EOF Print #intFile, Trim(ds!RegionDesc) ds.MoveNext Wend End If Close #intFile ds.Close Exit Function WriteErr: Exit Function End Function Private Sub BrowseButton_Click() On Error GoTo ErrTrap Load frmGetDir frmGetDir.SelDir = DirText.Text frmGetDir.Show vbModal If frmGetDir.SelDir <> "" Then If Len(frmGetDir.SelDir) > 110 Then MsgBox LoadResString(6059), 0 Else DirText.Text = frmGetDir.SelDir End If End If Unload frmGetDir On Error GoTo 0 Exit Sub ErrTrap: Exit Sub End Sub Private Sub cmbCancel_Click() On Error GoTo CancelErr Unload Me Exit Sub CancelErr: Resume Next End Sub Private Sub cmbOptions_Click() On Error GoTo ErrTrap frmcab.Show vbModal Dim rsConfig As Recordset Set rsConfig = gsyspb.OpenRecordset("select * from Configuration where Index = 1", dbOpenSnapshot) If Not IsNull(rsConfig!URL) Then ServerNameText.Caption = " " & rsConfig!URL ' HTTPocx.GetDoc "http://" & rsConfig!URL & "/pbserver/pbserver.asp" ' ServerStatusText.Caption = " " Else ServerNameText.Caption = "" 'ServerStatusText.Caption = "" End If rsConfig.Close Exit Sub ErrTrap: Exit Sub 'Dim rsConfig As recordset 'Set rsConfig = GsysPb.OpenRecordset("select * from Configuration where Index = 1", dbOpenSnapshot) 'If Not IsNull(rsConfig!URL) Then ' ServerNameText.Caption = " " & rsConfig!URL ' HTTPocx.GetDoc "http://" & rsConfig!URL & "/pbserver/pbserver.asp" ' ServerStatusText.Caption = " " 'Else ' ServerNameText.Caption = "" ' ServerStatusText.Caption = "" 'End If 'rsConfig.Close End Sub Private Sub Command1_Click() ' here's the 'create release' code 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 dblFreeSpace As Double Dim result As Integer Dim strucFname As OFSTRUCT Dim strSearchFile As String Dim strRelativePath As String On Error GoTo ErrTrap If Len(DirText.Text) > 110 Then MsgBox LoadResString(6059), 0 DirText.SetFocus Exit Sub End If If Trim(DirText.Text) = "" Or CheckPath(DirText.Text) <> 0 Then MsgBox LoadResString(6037), vbExclamation DirText.SetFocus Exit Sub Else DirText.Text = Trim(DirText.Text) If Right(DirText.Text, 1) = "\" Then DirText.Text = Left(DirText.Text, Len(DirText.Text) - 1) End If 'strRelPath = GetMyShortPath(DirText.Text & "\") strRelPath = DirText.Text & "\" End If dblFreeSpace = GetDriveSpace(DirText.Text, 350000) If dblFreeSpace = -2 Then Exit Sub End If Set config = gsyspb.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 config.Close MsgBox LoadResString(6038), vbInformation Exit Sub End If End If ' handle UI Screen.MousePointer = 11 Command1.Enabled = False cmbOptions.Enabled = False DirText.Enabled = False BrowseButton.Enabled = False cmbCancel.Enabled = False With ProgressBar1 .Visible = True .Value = 0 End With ChangeProgressBar 10 config.Edit config!PBbuildDir = DirText.Text config.Update vernum = txtver.Caption mastersql = "SELECT * from DialUpPort where Status = '1' order by AccessNumberId" Set GsysNDial = gsyspb.OpenRecordset(mastersql, dbOpenSnapshot) If GsysNDial.RecordCount = 0 Then 'master phone file Set GsysNDial = Nothing Command1.Enabled = True cmbOptions.Enabled = True DirText.Enabled = True BrowseButton.Enabled = True cmbCancel.Enabled = True ProgressBar1.Visible = False ProgressBar1.Value = 0 Screen.MousePointer = 0 MsgBox LoadResString(6039), vbExclamation Exit Sub Else sLong = strRelPath filesaveas = sLong & vernum & "Full.pbk" verfile = sLong & vernum & ".VER" 'fullddffile = sLong & vernum & "Full.ddf" masterOutfile filesaveas, GsysNDial FileCopy filesaveas, sLong & gsCurrentPB & ".pbk" VersionOutFile verfile, vernum 'outfullddf fullddffile, filesaveas, verfile, config outfullddf sLong, vernum & "Full.pbk", Str(vernum) 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 ChangeProgressBar 20 + 10 / vernum ChangeProgressBar 20 / vernum End If 'Check for existence of full.cab strSearchFile = sLong & vernum & "Full.cab" result = OpenFile(strSearchFile, strucFname, OF_EXIST) If result = -1 Then MsgBox LoadResString(6075), 0 Screen.MousePointer = 0 Command1.Enabled = True cmbOptions.Enabled = True DirText.Enabled = True BrowseButton.Enabled = True cmbCancel.Enabled = True With ProgressBar1 .Visible = False .Value = 0 End With Exit Sub End If If vernum > 1 Then deltasql = "Select * from delta order by DeltaNum" Set GsysNDelta = gsyspb.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 = gsyspb.OpenRecordset(deltasql, dbOpenSnapshot) filesaveas = sLong & vernum & "DTA" & previousver & ".pbk" dtaddffile = vernum & "DELTA" & previousver & ".ddf" deltaoutfile filesaveas, GsysNDelta 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 ChangeProgressBar 70 / (deltanum - 1) Next i% End If Set GsysNDial = Nothing Set GsysNDelta = Nothing If Trim(ServerNameText.Caption) <> "" Then Command3.Enabled = True End If cmbCancel.Enabled = True ProgressBar1.Visible = False ProgressBar1.Value = 0 Screen.MousePointer = 0 Exit Sub ErrTrap: Set GsysNDial = Nothing Set GsysNDelta = Nothing Command1.Enabled = True cmbOptions.Enabled = True cmbCancel.Enabled = True DirText.Enabled = True BrowseButton.Enabled = True ProgressBar1.Visible = False ProgressBar1.Value = 0 Screen.MousePointer = 0 If Err.Number = 3022 Then MsgBox LoadResString(6040), vbCritical ElseIf Err.Number = 75 Then MsgBox LoadResString(6041), vbCritical Else MsgBox LoadResString(6041), vbCritical End If Exit Sub End Sub Private Sub Command3_Click() Dim sql1 As String, sql2 As String Dim configure As Recordset 'Dim rsTemp As Recordset Dim i, intX As Integer, deltanum 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 sLong As String Dim postpath As Variant Dim filelen As Long Dim myValue As Long Dim intAuthCount As Integer Dim bErr As Boolean Dim bTriedRepair As Boolean Dim dblFreeSpace As Double Dim intVersion As Integer Dim intRC As Integer On Error GoTo ErrTrap dblFreeSpace = GetDriveSpace(DirText.Text, 400000) If dblFreeSpace = -2 Then Exit Sub End If ' handle UI Screen.MousePointer = 11 Command1.Enabled = False Command3.Enabled = False cmbCancel.Enabled = False ProgressBar1.Visible = True DoEvents On Error GoTo dbErr bTriedRepair = False intVersion = Val(txtver.Caption) deltanum = GetDeltaCount(intVersion) postpath = locPath + "pbserver.mdb" strPBName = gsCurrentPB strPBVirPath = ReplaceChars(strPBName, " ", "_") Set configure = gsyspb.OpenRecordset("select * from Configuration where Index = 1", dbOpenDynaset) intRC = UpdateHkeeper(postpath, gsCurrentPB, intVersion, strPBVirPath) ' intRC = PostFiles(configure!URL, configure!ServerUID, configure!ServerUID, intVersion, webpostdir, strPBVirPath) On Error GoTo ErrTrap ChangeProgressBar 15 ' here's the webpost stuff webpostdir = DirText.Text & "\" & 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 DirText.Text & "\" & intVersion & "full.cab", webpostdir & "\" & intVersion & "full.cab" previous = intVersion - deltanum For intX = 1 To deltanum strSource = DirText.Text & "\" & intVersion & "delta" & previous & ".cab" strDestination = webpostdir & "\" & intVersion & "delta" & previous & ".cab" FileCopy strSource, strDestination previous = previous + 1 Next intX 'sLong = GetMyShortPath(webpostdir) 'paths = sLong ChangeProgressBar 20 intRC = PostFiles(configure!URL, configure!ServerUID, configure!ServerPWD, intVersion, webpostdir, strPBVirPath) If intRC = 1 Then bErr = True If Not bErr Then GsysVer.AddNew GsysVer!version = intVersion GsysVer!CreationDate = lbldate.Caption GsysVer.Update Set GsysDelta = gsyspb.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" gsyspb.Execute sql1, dbFailOnError sql2 = "UPDATE delta SET DeltaNum = DeltaNum - 1" gsyspb.Execute sql2, dbFailOnError Set GsysDelta = gsyspb.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 'handle UI cmbCancel.Enabled = True ProgressBar1.Visible = False ProgressBar1.Value = 0 If bErr Then Command3.Enabled = True 'MsgBox LoadResString(6043), vbExclamation Else configure.Edit configure!NewVersion = 0 configure.Update Command3.Enabled = False LogPublish intVersion End If configure.Close Screen.MousePointer = 0 Exit Sub dbErr: postpath = locPath + "pbserver.mdb" If bTriedRepair Then MsgBox LoadResString(6055), vbCritical cmbCancel.Enabled = True Screen.MousePointer = 0 Else If CheckPath(postpath) <> 0 Then MsgBox LoadResString(6032) & Chr(13) & postpath, vbCritical cmbCancel.Enabled = True Screen.MousePointer = 0 Exit Sub Else bTriedRepair = True DBEngine.RepairDatabase postpath Resume Next End If End If Exit Sub ErrTrap: Set GsysDelta = Nothing 'Set GsysNDelta = Nothing If Err.Number = 76 Then postpath = locPath + "pbserver.mdb" Set Gsyspbpost = DBEngine.Workspaces(0).OpenDatabase(postpath) ' handle UI cmbCancel.Enabled = True DoEvents Command3_Click Exit Sub Else ' handle UI Screen.MousePointer = 0 Command3.Enabled = True cmbCancel.Enabled = True ProgressBar1.Visible = False ProgressBar1.Value = 0 MsgBox LoadResString(6043), vbExclamation Exit Sub End If End Sub Private Sub DirText_GotFocus() SelectText DirText End Sub Private Sub Form_KeyPress(KeyAscii As Integer) CheckChar KeyAscii End Sub Private Sub Form_Load() Dim Pbversion As Integer Dim testnum As Integer, testcheck As Integer Dim rsConfig As Recordset Set GsysVer = gsyspb.OpenRecordset("Select * from PhoneBookVersions order by version", dbOpenDynaset) Set GsysDelta = gsyspb.OpenRecordset("Select * from Delta order by DeltaNum", dbOpenDynaset) Set rsConfig = gsyspb.OpenRecordset("select * from Configuration where Index = 1", dbOpenSnapshot) If GsysVer.RecordCount = 0 Then Pbversion = 1 Else GsysVer.MoveLast Pbversion = GsysVer!version + 1 End If LoadBuildRes txtver.Caption = Pbversion Command1.Enabled = True Command3.Enabled = False DirText.Text = locPath & gsCurrentPB 'If Not IsNull(rsConfig!PBbuildDir) Then ' If CheckPath(rsConfig!PBbuildDir) = 0 Then ' DirText.Text = rsConfig!PBbuildDir ' End If 'End If If Not IsNull(rsConfig!URL) Then ' show info on PB server ServerNameText.Caption = " " & rsConfig!URL 'With HTTPocx ' .EnableTimer(prcConnectTimeout) = True ' .Timeout(prcConnectTimeout) = 30 ' .EnableTimer(prcReceiveTimeout) = True ' .Timeout(prcReceiveTimeout) = 30 '.EnableTimer(prcUserTimeout) = True '.Timeout(prcUserTimeout) = 30 'End With 'ServerStatusText.Caption = " " & LoadResString(5201) 'HTTPocx.GetDoc "//" & rsConfig!URL & "/pbserver/pbserver.dll" & _ "?ServiceName=11223399&pbVer=1&" End If rsConfig.Close CenterForm Me, Screen Screen.MousePointer = 0 End Sub Private Sub Form_Unload(Cancel As Integer) On Error Resume Next Screen.MousePointer = 0 GsysVer.Close GsysDelta.Close End Sub Private Sub txtver_Change() If txtver.Caption <> "" Then lbldate.Caption = Date Else lbldate.Caption = "" End If End Sub