You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2474 lines
80 KiB
2474 lines
80 KiB
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 ID>, new data
|
|
' Edit: <POP ID>, new data
|
|
' Delete: <POP ID>, 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:
|
|
' <region ID>, <region name>
|
|
'
|
|
' Add: <new region ID>, <new region name>
|
|
' Edit: <region ID>, <new region name>
|
|
' Delete: <region ID>, <empty string>
|
|
|
|
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
|
|
|
|
|