able/windows-nt
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity
windows-nt/Source/XPSP1/NT/net/rras/cps/pba/source/main.frm

2475 lines
77 KiB
Plaintext
Raw Normal View History

Add source files
2020-09-26 03:20:57 -05:00
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
Reference in a new issue Copy permalink