German VBS Problem

Prev: Find out where a user is logged in?
Next: objDSO.OpenDSObject Query from workgroup computer............

From: Crumb on 24 Jan 2006 12:37

---

Hi,

I have a problem with a German VB file which I am sure is related to
the time and date format used in the UK dd.mm.yyyy

If i sent my PC to location Germany then the code works.

Can any help, here is the code

'***************************************
'**** Author Eve
'**** Swyx Communications AG
'**** Import Call Detail Records
'**************************************
'Version 1.03

'Public Const LOCALE_SSHORTDATE = &H1F

Public Declare Function GetSystemDefaultLCID _
Lib "kernel32" () As Long

Public Declare Function SetLocaleInfo _
Lib "kernel32" Alias "SetLocaleInfoA" ( _
ByVal Locale As Long, _
ByVal LCType As Long, _
ByVal lpLCData As String) As Boolean

Public box3, box4_1, box4_0 As Variant

'***********ADD IN**********************
'automated macro to make a new taskbar entry
'***************************************
'#1
Sub Auto_open()

Application.DisplayAlerts = False
Dim ComBar As CommandBar

On Error GoTo ErrLabel

'make a new taskbar entry "Call Detail Records
'with sub entries "Load Data" and "Save Data"
Const MenueName = "Call Detail Records"

'count entries with name "Call Detail Records"
Dim i
i = 0
For Each ComBar In Application.CommandBars
If ComBar.Name = "Call Detail Records" Then
i = i + 1
End If
Next
'if entry already existe, delete all entries
If i > 0 Then
ComBar.Delete
Exit Sub
i = 0
End If

'create new entry
With Application.MenuBars(xlWorksheet)
.Menus.Add Caption:=MenueName
'.Menus(MenueName).MenuItems.Add Caption:="Load CDR Version
3.20", OnAction:="WarningMessageV3"
.Menus(MenueName).MenuItems.Add Caption:="Load CDR",
OnAction:="WarningMessageV4_0"
'.Menus(MenueName).MenuItems.Add Caption:="Load CDR Version
4.10", OnAction:="WarningMessageV4_1"
.Menus(MenueName).MenuItems.Add Caption:="Save Data",
OnAction:="SaveData"
End With


'delete 3rd worksheet
Dim wkstemp
Set wkstemp = Application.ActiveWorkbook.Worksheets(3)
wkstemp.Select

Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

ErrLabel:
End Sub

'****LOAD USERFORM**********************
'calls UserForm to choose the starting and finish date
'***************************************
'#2
Sub LoadDialog_Load()

LoadDialog.CalendarStart.value = Now
LoadDialog.CalendarFinish.value = Now
'Ian Rowan
LoadDialog.txtInputPathName.value = "\\avebury\swyx\"
LoadDialog.Show

End Sub
'#4
Sub WarningMessageV4_0()

box4_0 = 1
Call LoadDialog_Load

End Sub
'#5
Sub WarningMessageV4_1()

box4_1 = 1
Call LoadDialog_Load

End Sub

'***********LOAD DATA*******************
'main macro to load and format the call detail records
'***************************************
'#6
Sub LoadData()

Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Show text of Label in Userform
LoadDialog.Label5.Visible = True
LoadDialog.Repaint

'***********DECLARATION*****************
'***************************************

'worksheets
Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim wks3 As Worksheet

'of columns of Origination Nr & Name, Destination Nr & Name
'Start Date & Time, End Date & Time, Duration (SumDif between Start
time
' & end time), Currency, Costs, State, Public Access Prefix, Project
Number,
'AOC for wks1
Dim xColOrigiNum&
Dim xColOrigiName&
Dim xColCalledNum&
Dim xColCalledName&
Dim xColDestNum&
Dim xColDestName&
Dim xColStartDate&
Dim xColStartTime&
Dim xColEndDate&
Dim xColEndTime&
Dim xColSumDif&
Dim xColCurrency&
Dim xColCosts&
Dim xColState&
Dim xColPAP&
Dim xColLCR&
Dim xColProjNum&
Dim xColAOC&
Dim xColOrigiDevice&
Dim xColDestDevice&

'statistics
Dim xColStatistics& '= xColOrigiNum&
Dim xColStatistics2&
Dim xColResults& '= xColOrigiName&
Dim xColResultsInt2&
Dim xColResultsExt2&

Dim xRowStatistics&
Dim xRowAllCalls&
Dim xRowIntCalls&
Dim xRowExtCalls&
Dim xRowCosts&
Dim xRowCostCalls&
Dim xRowTime&
Dim xRowDurCalls&

Dim xRowStatus&
Dim xRowExtConnected&
Dim xRowExtAlerting&
Dim xRowExtInit&
Dim xRowExtHold&
Dim xRowExtTransf&


'Time Per Call (= sumdiff ), Costs Per Name for wks2
Dim xColDestNum2&
Dim xColDestName2&
Dim xColStartDate2&
Dim xColStartTime2&
Dim xColTimePerCall&
Dim xColCostsPerName&

'rows
Dim xRowHeader& 'first row for header
Dim xRowFirst& 'second row = first row to insert cdr
Dim xRowLast& 'last written row
Dim xRowTotal& 'row after xRowLast& to calculate total time and
costs
Dim xRowActive& 'current active row
Dim xRowTemp&

'current caller name
Dim xColOrigiNameValue As Variant

'results wks1
Dim xSumDif#
Dim xTotalTime#
Dim xTotalCosts#

'statistics wks1

Dim xAllCalls#
Dim xDurCalls#
Dim xIntCalls#
Dim xExtCalls#
Dim xCostCalls#

Dim xExtConnected#
Dim xExtAlerting#
Dim xExtInit#
Dim xExtHold#
Dim xExtTransf#

Dim xIntConnected#
Dim xIntAlerting#
Dim xIntInit#
Dim xIntHold#
Dim xIntTransf#

Dim beginDate
Dim endDate


'***********INITIALIZATION**************
'***************************************

'Set fixed german date format for all date operations,
'since Swyx Server creates CDR files with fixed german
'date format !
' Dim lngLocale As Long
' lngLocale = GetSystemDefaultLCID()
'bReturn = SetLocaleInfo(lngLocale, LOCALE_SSHORTDATE, "MM.dd.yyyy")


'initialize rows
xRowHeader& = 1
xRowFirst& = 2
xRowTemp& = 2

'initialize columns for wks1
xColOrigiNum& = 1
xColOrigiName& = 2
xColOrigiDevice& = 3
xColCalledNum& = 4
xColCalledName& = 5
xColDestNum& = 6
xColDestName& = 7
xColDestDevice& = 8
xColStartDate& = 9
xColStartTime& = 10
xColEndDate& = 11
xColEndTime& = 12
xColSumDif& = 13
xColCurrency& = 14
xColCosts& = 15
xColState& = 16
xColPAP& = 17
xColLCR& = 18
xColProjNum& = 19
xColAOC& = 20

'Statistics
xColStatistics& = 1
xColResults& = 2
xColStatistics2& = 4
xColResultsInt2& = 5
xColResultsExt2& = 6

'wks2
xColDestNum2& = 3
xColDestName2& = 4
xColStartDate2& = 5
xColStartTime2& = 6
xColTimePerCall& = 7
xColCostsPerName& = 8

'define workbook with its worksheets
ActiveWorkbook.Author = "Eve*"
Set wks1 = Application.ActiveWorkbook.Worksheets(1)
Set wks2 = Application.ActiveWorkbook.Worksheets(2)
Set wks3 = Application.ActiveWorkbook.Worksheets(3)
wks1.Cells.Delete Shift:=xlUp
wks2.Cells.Delete Shift:=xlUp
wks3.Cells.Delete Shift:=xlUp

'format worksheets
wks1.Name = "CDR Total"
wks2.Name = "CDR per Name"
wks3.Name = "Profile"
wks1.Cells.NumberFormat = "General"
wks2.Cells.NumberFormat = "General"
wks3.Cells.NumberFormat = "General"

'format columns "@" = Stringformat
wks1.Columns("A").NumberFormat = "@"
wks1.Columns("B").NumberFormat = "@"
wks1.Columns("C").NumberFormat = "@"
wks1.Columns("D").NumberFormat = "@"
wks1.Columns("E").NumberFormat = "@"
wks1.Columns("F").NumberFormat = "@"
wks1.Columns("G").NumberFormat = "@"
wks1.Columns("H").NumberFormat = "@"
wks1.Columns("N").NumberFormat = "@"
wks1.Columns("O").NumberFormat = "@"
wks2.Columns("A").NumberFormat = "@"
wks2.Columns("B").NumberFormat = "@"
wks2.Columns("C").NumberFormat = "@"
wks2.Columns("D").NumberFormat = "@"

'clean up wks1
wks1.Select
Selection.ClearContents
Selection.ClearFormats

'get Value of DTPickers
beginDate = LoadDialog.beginDate
endDate = LoadDialog.endDate



'***********SEARCH IN TEXTFILE**********
'***************************************

'Declaration
Dim curPath$
Dim xCount&
Dim i&
Dim Filename$
Dim Titelline$
Dim TokensTemp As Variant
Dim compareToken
Dim compareTokenV3x
Dim compareTokenV40
Dim compareTokenV41

Dim Titleline

Dim DataLine$
Dim Tokens As Variant

Dim TempOrigiNum
Dim TempOrigiName
Dim TempCalledNum
Dim TempCalledName
Dim TempDestNum
Dim TempDestName
Dim TempStartDate
Dim TempStartTime
Dim TempEndDate
Dim TempEndTime
Dim TempCurrency
Dim TempCosts
Dim TempState
Dim TempPAP
Dim TempLCR
Dim TempProjNum
Dim TempAOC
Dim TempOrigiDevice
Dim TempDestDevice

Dim fs
Dim myfile 'As Scripting.File
Dim myfilestream 'As Scripting.TextStream

Dim value, delta, flag, count, startminuten, stopminuten

'get current pathname from textbox
curPath$ = LoadDialog.curPath

'Have to change the path
Application.FileSearch.LookIn = curPath$
Application.FileSearch.Filename = "*.txt"
Application.FileSearch.FileType = msoFileTypeAllFiles

Application.FileSearch.Execute

'Number of files in the directory
xCount& = Application.FileSearch.FoundFiles.count

'#7
'for each file
For i = 1 To xCount&
On Error GoTo 100

Filename = Application.FileSearch.FoundFiles.Item(i)
Set fs = CreateObject("Scripting.FileSystemObject")
Set myfile = fs.GetFile(Filename)
Set myfilestream = myfile.OpenAsTextStream(1, -2)

'ingore first line with titles
Titleline = myfilestream.ReadLine
TokensTemp = Split(Titleline, """")
If InStr(Titleline, "IpPbxSrv") > 0 Then
Titleline = myfilestream.ReadLine
TokensTemp = Split(Titleline, """")
End If

If UBound(TokensTemp) > 0 Then

compareToken = TokensTemp(1)
compareTokenV40 = "OriginationNumber" 'version 4.0
compareTokenV41 = "CallID" 'version 4.10

'#8 Check if csv entry is for version 4.0
If StrComp(compareToken, compareTokenV40, vbTextCompare) = 0 And
StrComp(compareTokenV3x, compareTokenV40, vbTextCompare) = 0 Then
Do
LoadDialog.MousePointer = fmMousePointerHourGlass
'read line
'this is the first data line
DataLine = myfilestream.ReadLine
Tokens = Split(DataLine, """")

'take the tokens for each cell in the excelsheet
TempOrigiNum = Tokens(1)
TempOrigiName = Tokens(3)
TempCalledNum = Tokens(5)
TempCalledName = Tokens(7)
TempDestNum = Tokens(9)
TempDestName = Tokens(11)
TempStartDate = Tokens(13)
TempStartTime = Tokens(15)
TempEndDate = Tokens(17)
TempEndTime = Tokens(19)
TempCurrency = Tokens(21)
TempCosts = Tokens(23)
TempState = Tokens(25)
TempPAP = Tokens(27)
TempLCR = Tokens(29)
TempProjNum = Tokens(31)
TempAOC = Tokens(33)
TempOrigiDevice = Tokens(35)
TempDestDevice = Tokens(37)

'#9 proof if date is valid
If CDate(TempStartDate) >= CDate(beginDate) And
CDate(TempStartDate) <= CDate(endDate) Then

'insert tokens in the cell of the excelsheet
wks1.Cells(xRowTemp&, xColOrigiNum&).value =
CStr(TempOrigiNum)
wks1.Cells(xRowTemp&, xColOrigiName&).value =
CVar(TempOrigiName)
wks1.Cells(xRowTemp&, xColOrigiDevice&).value =
CVar(TempOrigiDevice)
wks1.Cells(xRowTemp&, xColCalledNum&).value =
CStr(TempCalledNum)
wks1.Cells(xRowTemp&, xColCalledName&).value =
CVar(TempCalledName)
wks1.Cells(xRowTemp&, xColDestNum&).value =
CStr(TempDestNum)
wks1.Cells(xRowTemp&, xColDestName&).value =
CVar(TempDestName)
wks1.Cells(xRowTemp&, xColDestDevice&).value =
CVar(TempDestDevice)
wks1.Cells(xRowTemp&, xColStartDate&).value =
CDate(TempStartDate)
wks1.Cells(xRowTemp&, xColStartTime&).value =
CDate(TempStartTime)
wks1.Cells(xRowTemp&, xColEndDate&).value =
CDate(TempEndDate)
wks1.Cells(xRowTemp&, xColEndTime&).value =
CDate(TempEndTime)
wks1.Cells(xRowTemp&, xColCurrency&).value =
CStr(TempCurrency)
wks1.Cells(xRowTemp&, xColCosts&).value =
CDbl(TempCosts) / 100
wks1.Cells(xRowTemp&, xColState&).value =
CVar(TempState)
wks1.Cells(xRowTemp&, xColPAP&).value = CVar(TempPAP)
wks1.Cells(xRowTemp&, xColLCR&).value = CVar(TempLCR)
wks1.Cells(xRowTemp&, xColProjNum&).value =
CVar(TempProjNum)
wks1.Cells(xRowTemp&, xColAOC&).value = CVar(TempAOC)
xRowTemp& = xRowTemp& + 1
End If

'get next file if found end of file
If myfilestream.AtEndOfStream = True Then
Exit Do
End If

'#9 proof if date is valid
Loop While CDate(TempStartDate) <= CDate(endDate)
End If

'#10 Check if csv entry is for version 4.10
If StrComp(compareToken, compareTokenV41, vbTextCompare) = 0
Then
'Call LoadData4_1
'Exit Sub
Do
LoadDialog.MousePointer = fmMousePointerHourGlass
'read line
'this is the first data line
DataLine = myfilestream.ReadLine
Tokens = Split(DataLine, """")

'take the tokens for each cell in the excelsheet
TempOrigiNum = Tokens(3)
TempOrigiName = Tokens(5)
TempCalledNum = Tokens(7)
TempCalledName = Tokens(9)
TempDestNum = Tokens(11)
TempDestName = Tokens(13)
TempStartDate = Tokens(15)
TempStartTime = Tokens(17)
TempEndDate = Tokens(31)
TempEndTime = Tokens(33)
TempCurrency = Tokens(35)
TempCosts = Tokens(37)
TempState = Tokens(39)
TempPAP = Tokens(41)
TempLCR = Tokens(43)
TempProjNum = Tokens(45)
TempAOC = Tokens(47)
TempOrigiDevice = Tokens(49)
TempDestDevice = Tokens(51)

'#9 proof if date is valid
If CDate(TempStartDate) >= CDate(beginDate) And
CDate(TempStartDate) <= CDate(endDate) Then

'insert tokens in the cell of the excelsheet
wks1.Cells(xRowTemp&, xColOrigiNum&).value =
CStr(TempOrigiNum)
wks1.Cells(xRowTemp&, xColOrigiName&).value =
CVar(TempOrigiName)
wks1.Cells(xRowTemp&, xColOrigiDevice&).value =
CVar(TempOrigiDevice)
wks1.Cells(xRowTemp&, xColCalledNum&).value =
CStr(TempCalledNum)
wks1.Cells(xRowTemp&, xColCalledName&).value =
CVar(TempCalledName)
wks1.Cells(xRowTemp&, xColDestNum&).value =
CStr(TempDestNum)
wks1.Cells(xRowTemp&, xColDestName&).value =
CVar(TempDestName)
wks1.Cells(xRowTemp&, xColDestDevice&).value =
CVar(TempDestDevice)
wks1.Cells(xRowTemp&, xColStartDate&).value =
CDate(TempStartDate)
wks1.Cells(xRowTemp&, xColStartTime&).value =
CDate(TempStartTime)
wks1.Cells(xRowTemp&, xColEndDate&).value =
CDate(TempEndDate)
wks1.Cells(xRowTemp&, xColEndTime&).value =
CDate(TempEndTime)
wks1.Cells(xRowTemp&, xColCurrency&).value =
CStr(TempCurrency)
wks1.Cells(xRowTemp&, xColCosts&).value =
CDbl(TempCosts) / 100
wks1.Cells(xRowTemp&, xColState&).value =
CVar(TempState)
wks1.Cells(xRowTemp&, xColPAP&).value =
CVar(TempPAP)
wks1.Cells(xRowTemp&, xColLCR&).value =
CVar(TempLCR)
wks1.Cells(xRowTemp&, xColProjNum&).value =
CVar(TempProjNum)
wks1.Cells(xRowTemp&, xColAOC&).value =
CVar(TempAOC)
xRowTemp& = xRowTemp& + 1
End If

'get next file if found end of file
If myfilestream.AtEndOfStream = True Then
Exit Do
End If

'#9 proof if date is valid
Loop While CDate(TempStartDate) <= CDate(endDate)
End If
End If
Next

100:

On Error Resume Next

'************** FORMAT WORKSHEET 1 *****
'***************************************

'#11 define value of headers
wks1.Cells(xRowHeader&, xColOrigiNum&).value = "Caller, Number"
wks1.Cells(xRowHeader&, xColOrigiName&).value = "Caller, Name"
wks1.Cells(xRowHeader&, xColOrigiDevice&).value = "Caller, Device"
wks1.Cells(xRowHeader&, xColCalledNum&).value = "Called, Number"
wks1.Cells(xRowHeader&, xColCalledName&).value = "Called, Name"
wks1.Cells(xRowHeader&, xColDestNum&).value = "Destination, Number"
wks1.Cells(xRowHeader&, xColDestName&).value = "Destination, Name"
wks1.Cells(xRowHeader&, xColDestDevice&).value = "Destination,
Device"
wks1.Cells(xRowHeader&, xColStartDate&).value = "Starting Date"
wks1.Cells(xRowHeader&, xColStartTime&).value = "Starting Time"
wks1.Cells(xRowHeader&, xColEndDate&).value = "Finish Date"
wks1.Cells(xRowHeader&, xColEndTime&).value = "Finish Time"
wks1.Cells(xRowHeader&, xColSumDif&).value = "Duration"
wks1.Cells(xRowHeader&, xColCurrency&).value = "Currency"
wks1.Cells(xRowHeader&, xColCosts&).value = "Costs"
wks1.Cells(xRowHeader&, xColState&).value = "State"
wks1.Cells(xRowHeader&, xColPAP&).value = "PAP"
wks1.Cells(xRowHeader&, xColLCR&).value = "Provider"
wks1.Cells(xRowHeader&, xColProjNum&).value = "Project"
wks1.Cells(xRowHeader&, xColAOC&).value = "AOC"

'define format
wks1.Columns("A").NumberFormat = "@"
wks1.Columns("B").NumberFormat = "@"
wks1.Columns("C").NumberFormat = "@"
wks1.Columns("D").NumberFormat = "@"
wks1.Columns("E").NumberFormat = "@"
wks1.Columns("F").NumberFormat = "@"
wks1.Columns("G").NumberFormat = "@"
wks1.Columns("H").NumberFormat = "@"
wks1.Columns("I").NumberFormat = "dd/mm/yyyy"
wks1.Columns("J").NumberFormat = "hh:mm:ss"
wks1.Columns("K").NumberFormat = "dd/mm/yyyy"
wks1.Columns("L").NumberFormat = "hh:mm:ss"
wks1.Columns("M").NumberFormat = "hh:mm:ss"
wks1.Columns("N").NumberFormat = "@"
wks1.Columns("O").NumberFormat = "#,##0.00"

'#12 Error message: if first value of csv is 0
If wks1.Cells(2, 2).value = 0 Then
Dim tempbox
tempbox = MsgBox("No data was found with the given date." & _
"Please verify your selection!", vbOKOnly, "Error occured")
LoadDialog.Hide
LoadDialog.MousePointer = fmMousePointerArrow
Exit Sub
End If

'format worksheet1
wks1.Activate
wks1.Cells(1, 1).Select
ActiveCell.CurrentRegion.Select

'#13 format headers bold and align middle
Selection.AutoFormat Format:=xlRangeAutoFormatSimple, Number:=True,
Font _
:=True, Alignment:=True, Border:=True, Pattern:=True,
Width:=True

'sort in alphabetical order
Selection.Sort key1:=Cells(xRowFirst&, xColOrigiNum&),
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

'allow word-wrap
With Selection
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False

End With

'freeze the headers, so you always see them while scrolling
Rows("2:2").Select
ActiveWindow.FreezePanes = True

'Change caption of Label in the dialog
LoadDialog.Label5.Caption = "..... processing ....."

LoadDialog.Repaint



'**CALCULATE TOTAL TIME, WORKSHEET 1 AND WORKSHEET 2***
'*******************************************************

'count till last row
xRowLast& = wks1.Cells(wks1.Rows.count, xColEndTime&).End(xlUp).Row
xRowTotal& = xRowLast& + 1 'last active row + 1 - to show total
result

'current active row
For xRowActive& = xRowFirst& To xRowLast&

'#14 calculate xSumDif#
'proof valid cdr entry
If wks1.Cells(xRowActive&, xColStartTime&).value <=
wks1.Cells(xRowActive&, xColEndTime&).value Then

xSumDif# = wks1.Cells(xRowActive&, xColEndTime&).value -
wks1.Cells(xRowActive&, xColStartTime&).value

'xSumDif# for worksheet1
wks1.Cells(xRowActive&, xColSumDif&).NumberFormat =
"[hh]:mm:ss"
wks1.Cells(xRowActive&, xColSumDif&).FormulaR1C1 =
CDate(xSumDif#)

'xSumDif# for worksheet2
wks2.Cells(xRowActive&, xColTimePerCall&).NumberFormat =
"[hh]:mm:ss"
wks2.Cells(xRowActive&, xColTimePerCall&).FormulaR1C1 =
CDate(xSumDif#)

xTotalTime# = xTotalTime# + xSumDif#
xTotalCosts# = xTotalCosts# + CDec(wks1.Cells(xRowActive&,
xColCosts&).value)
Else
'if time value is not valid
xSumDif# = 0

Dim box
'box = MsgBox("Please verify the original cdr file." &
Chr(10) & "The end of the call is dated before the starting time." _
'& Chr(10) & "The error occured in line: " & xRowActive&,
48, "Warning: Wrong time")
wks1.Cells(xRowActive&, xColSumDif&).value = "Error"
End If

'#15 internal or external call?
If wks1.Cells(xRowActive&, xColAOC&).value = "1" Then
xExtCalls# = xExtCalls# + 1 'iterate external calls
End If

'which state
'connected
If wks1.Cells(xRowActive&, xColState&).value = "Connected" Then
If wks1.Cells(xRowActive&, xColAOC&).value = "1" Then
xExtConnected# = xExtConnected# + 1 'iterate external
calls with state "connected"
Else
xIntConnected# = xIntConnected# + 1
End If
End If

'calling
If wks1.Cells(xRowActive&, xColState&).value = "Alerting" Then
If wks1.Cells(xRowActive&, xColAOC&).value = "1" Then
xExtAlerting# = xExtAlerting# + 1 'iterate external calls
with state "calling"
Else
xIntAlerting# = xIntAlerting# + 1
End If
End If

'initialized
If wks1.Cells(xRowActive&, xColState&).value = "Initialized"
Then
If wks1.Cells(xRowActive&, xColAOC&).value = "1" Then
xExtInit# = xExtInit# + 1 'iterate external calls with
state "initialized"
Else
xIntInit# = xIntInit# + 1
End If
End If

'holding
If wks1.Cells(xRowActive&, xColState&).value = "On hold" Then
If wks1.Cells(xRowActive&, xColAOC&).value = "1" Then
xExtHold# = xExtHold# + 1 'iterate external calls with
state "holding"
Else
xIntHold# = xIntHold# + 1
End If
End If

'transferring
If wks1.Cells(xRowActive&, xColState&).value = "Transferred"
Then
If wks1.Cells(xRowActive&, xColAOC&).value = "1" Then
xExtTransf# = xExtTransf# + 1 'iterate external calls
with state "holding"
Else
xIntTransf# = xIntTransf# + 1
End If
End If
Next

'#16 format total costs
wks1.Cells(xRowTotal&, xColCosts&).NumberFormat = "#,##0.00"
wks1.Cells(xRowTotal&, xColCosts&).Font.Bold = True
wks1.Cells(xRowTotal&, xColCosts&).EntireColumn.AutoFit
wks1.Cells(xRowTotal&, xColCosts&).value = CDec(xTotalCosts#)

'format total time
wks1.Cells(xRowTotal&, xColSumDif&).NumberFormat = "[hh]:mm:ss"
wks1.Cells(xRowTotal&, xColSumDif&).Font.Bold = True
wks1.Cells(xRowTotal&, xColSumDif&).EntireColumn.AutoFit
wks1.Cells(xRowTotal&, xColSumDif&).value = CDec(xTotalTime#)


'#17 calculate nr of all calls, average duration, all external calls
and
'average costs

xAllCalls# = xRowLast& - 1
xIntCalls# = xAllCalls# - xExtCalls#

'avoid a zero-devision
If xExtConnected# <> 0 Then
xCostCalls# = xTotalCosts# / xExtConnected#
Else
xCostCalls# = 0
End If

'avoid a zero-devision
If xAllCalls# <> 0 Then
xDurCalls# = xTotalTime# / xAllCalls#
Else
xDurCalls# = 0
End If

'#18 row position for statistics
xRowStatistics& = xRowTotal& + 2
xRowAllCalls& = xRowTotal& + 3
xRowIntCalls& = xRowTotal& + 4
xRowExtCalls& = xRowTotal& + 5
xRowCosts& = xRowTotal& + 6
xRowCostCalls& = xRowTotal& + 7
xRowTime& = xRowTotal& + 8
xRowDurCalls& = xRowTotal& + 9

xRowStatus& = xRowTotal& + 3
xRowExtConnected& = xRowTotal& + 4
xRowExtAlerting& = xRowTotal& + 5
xRowExtInit& = xRowTotal& + 6
xRowExtHold& = xRowTotal& + 7
xRowExtTransf& = xRowTotal + 8

'format font
wks1.Range(Cells(xRowStatistics&, xColStatistics&),
Cells(xRowDurCalls&, xColStatistics&)).Font.Bold = True
wks1.Range(Cells(xRowStatistics&, xColStatistics2&),
Cells(xRowExtTransf&, xColStatistics2&)).Font.Bold = True

'header for statistics
wks1.Cells(xRowStatistics&, xColStatistics&).value = "Statistics:"
wks1.Cells(xRowAllCalls&, xColStatistics&).value = "All Calls:"
wks1.Cells(xRowIntCalls&, xColStatistics&).value = "Internal Calls:"
wks1.Cells(xRowExtCalls&, xColStatistics&).value = "External Calls:"
wks1.Cells(xRowCosts&, xColStatistics&).value = "Total Costs:"
'wks1.Cells(xRowCostCalls&, xColStatistics&).value = Chr(216) & "
Costs:"
wks1.Cells(xRowCostCalls&, xColStatistics&).value = " Costs:"
wks1.Cells(xRowTime&, xColStatistics&).value = "Total Time:"
'wks1.Cells(xRowDurCalls&, xColStatistics&).value = Chr(216) & "
Duration:"
wks1.Cells(xRowDurCalls&, xColStatistics&).value = " Duration:"

wks1.Cells(xRowStatistics&, xColStatistics2&).value = "Statistics:"
wks1.Cells(xRowStatus&, xColStatistics2&).value = "Status:"
wks1.Cells(xRowExtConnected&, xColStatistics2&).value = "Connected:"
wks1.Cells(xRowExtAlerting&, xColStatistics2&).value = "Alerting:"
wks1.Cells(xRowExtInit&, xColStatistics2&).value = "Initialized:"
wks1.Cells(xRowExtHold&, xColStatistics2&).value = "Holding:"
wks1.Cells(xRowExtTransf&, xColStatistics2&).value = "Transferred:"

wks1.Cells(xRowStatus&, xColResultsInt2&).value = "Internal"
wks1.Cells(xRowStatus&, xColResultsExt2&).value = "External"

'show results
wks1.Cells(xRowAllCalls&, xColResults&).value = xAllCalls#
wks1.Cells(xRowIntCalls&, xColResults&).value = xIntCalls#
wks1.Cells(xRowExtCalls&, xColResults&).value = xExtCalls#
wks1.Cells(xRowCosts&, xColResults&).value = xTotalCosts#
wks1.Cells(xRowCostCalls&, xColResults&).value = xCostCalls#
wks1.Cells(xRowTime&, xColResults&).value = xTotalTime#
wks1.Cells(xRowDurCalls&, xColResults&).value = xDurCalls#

wks1.Cells(xRowExtConnected&, xColResultsExt2&).value =
xExtConnected#
wks1.Cells(xRowExtAlerting&, xColResultsExt2&).value = xExtAlerting#
wks1.Cells(xRowExtInit&, xColResultsExt2&).value = xExtInit#
wks1.Cells(xRowExtHold&, xColResultsExt2&).value = xExtHold#
wks1.Cells(xRowExtTransf&, xColResultsExt2&).value = xExtTransf#

wks1.Cells(xRowExtConnected&, xColResultsInt2&).value =
xIntConnected#
wks1.Cells(xRowExtAlerting&, xColResultsInt2&).value = xIntAlerting#
wks1.Cells(xRowExtInit&, xColResultsInt2&).value = xIntInit#
wks1.Cells(xRowExtHold&, xColResultsInt2&).value = xIntHold#
wks1.Cells(xRowExtTransf&, xColResultsInt2&).value = xIntTransf#

'format results
wks1.Cells(xRowCosts&, xColResults&).NumberFormat = "#,##0.00"
wks1.Cells(xRowCostCalls&, xColResults&).NumberFormat = "#,##0.00"
wks1.Cells(xRowTime&, xColResults&).NumberFormat = "[hh]:mm:ss"
wks1.Cells(xRowDurCalls&, xColResults&).NumberFormat = "[hh]:mm:ss"

'format statistics
Range(Cells(xRowStatistics&, xColStatistics&), Cells(xRowDurCalls&,
xColResults&)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

'format statistics
Range(Cells(xRowStatistics&, xColStatistics2&),
Cells(xRowExtTransf&, xColResultsExt2&)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

'****FORMAT HEADER OF WORKSHEET 2 *****
'**************************************
'#19
'define headers
wks2.Cells(xRowHeader&, xColOrigiNum&).value = "Caller, Name"
wks2.Cells(xRowHeader&, xColOrigiName&).value = "Caller, Number"
wks2.Cells(xRowHeader&, xColDestNum2&).value = "Destination, Name"
wks2.Cells(xRowHeader&, xColDestName2&).value = "Destination, Number"
wks2.Cells(xRowHeader&, xColStartDate2&).value = "Starting Date"
wks2.Cells(xRowHeader&, xColStartTime2&).value = "Starting Time"
wks2.Cells(xRowHeader&, xColTimePerCall&).value = "Duration"
wks2.Cells(xRowHeader&, xColCostsPerName&).value = "Costs per Name"

'format headers
wks2.Columns(1).NumberFormat = "@"
wks2.Columns(2).NumberFormat = "@"
wks2.Columns(3).NumberFormat = "@"
wks2.Columns(4).NumberFormat = "@"
wks2.Columns(5).NumberFormat = "dd/mm/yyyy"
wks2.Columns(6).NumberFormat = "[hh]:mm:ss"
wks2.Columns(7).NumberFormat = "[hh]:mm:ss"
wks2.Columns(8).NumberFormat = "#,##0.00"

'***** GET DATA FROM WORKSHEET 1 ******
'**********TO WORKSHEET 3 *************
'**************************************
'#20
'active rows
value = 0
delta = 30 ' alle 30 minuten
xRowActive& = 2
For value = 0 To 24 * 60 Step delta
wks3.Cells(xRowActive&, 1).value = value
wks3.Cells(xRowActive&, 2).value = TimeSerial(0, value, 0)
wks3.Cells(xRowActive&, 3).value = 0
xRowActive& = xRowActive& + 1
Next

Sheets("Profile").Select
Columns("B:B").Select
Selection.NumberFormat = "h:mm;@"

For xRowActive& = xRowFirst& To xRowLast&
startminuten = Hour(wks1.Cells(xRowActive&, xColStartTime&).value)
* 60 + Minute(wks1.Cells(xRowActive&, xColStartTime&).value)
stopminuten = Hour(wks1.Cells(xRowActive&, xColEndTime&).value) *
60 + Minute(wks1.Cells(xRowActive&, xColEndTime&).value)
flag = 0
count = 2
For value = 0 To 24 * 60 - 1 Step delta
If value <= stopminuten And flag = 1 Then
wks3.Cells(count, 3).value = wks3.Cells(count, 3).value + 1
End If
If value >= startminuten And flag = 0 Then
wks3.Cells(count, 3).value = wks3.Cells(count, 3).value + 1
flag = 1
End If
count = count + 1
Next
Next

For count = 1 To 7 Step 1
wks3.Cells(count + 1, 4).value = WeekdayName(count)
Next

wks3.Cells(1, 5).value = "external"
wks3.Cells(1, 6).value = "internal"

For xRowActive& = xRowFirst& To xRowLast&
If wks1.Cells(xRowActive&, xColState&).value = "Connected" Then
If wks1.Cells(xRowActive&, xColAOC&).value = "1" Then
'iterate external calls
startminuten = Weekday(wks1.Cells(xRowActive&,
xColStartDate&).value, 2)
wks3.Cells(startminuten + 1, 5).value =
wks3.Cells(startminuten + 1, 5).value + 1
Else
'iterate internal calls
startminuten = Weekday(wks1.Cells(xRowActive&,
xColStartDate&).value, 2)
wks3.Cells(startminuten + 1, 6).value =
wks3.Cells(startminuten + 1, 6).value + 1
End If
End If
Next

'
' Makro2 Makro
' Makro am 30.12.2002 von Uwe Sauerbrey aufgezeichnet
'
'
Charts.Add
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData
Source:=Sheets("Profile").Range("B2:C49"), PlotBy:=xlColumns
ActiveChart.Location Where:=xlLocationAsObject, Name:="Profile"
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.text = "Calls during 24h"
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.text = "calls"
End With
With ActiveChart.Axes(xlCategory)
.HasMajorGridlines = False
.HasMinorGridlines = False
End With
With ActiveChart.Axes(xlValue)
.HasMajorGridlines = True
.HasMinorGridlines = False
End With
ActiveChart.HasLegend = False
ActiveChart.HasDataTable = False
ActiveChart.Axes(xlCategory).Select
With ActiveChart.Axes(xlCategory)
.CrossesAt = 1
.TickLabelSpacing = 2
.TickMarkSpacing = 1
.AxisBetweenCategories = True
.ReversePlotOrder = False
End With
With Selection.TickLabels
.Alignment = xlCenter
.Offset = 100
.ReadingOrder = xlContext
.Orientation = xlUpward
End With

Charts.Add
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Sheets("Profile").Range("D1:F8"),
PlotBy:=xlColumns
ActiveChart.Location Where:=xlLocationAsObject, Name:="Profile"
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.text = "Calls during the week"
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.text = "calls"
End With
With ActiveChart.Axes(xlCategory)
.HasMajorGridlines = False
.HasMinorGridlines = False
End With
With ActiveChart.Axes(xlValue)
.HasMajorGridlines = True
.HasMinorGridlines = False
End With
ActiveChart.HasLegend = False
ActiveChart.HasDataTable = False
ActiveChart.Axes(xlCategory).Select
With ActiveChart.Axes(xlCategory)
.CrossesAt = 1
.TickLabelSpacing = 2
.TickMarkSpacing = 1
.AxisBetweenCategories = True
.ReversePlotOrder = False
End With
With Selection.TickLabels
.Alignment = xlCenter
.Offset = 100
.ReadingOrder = xlContext
.Orientation = xlUpward
End With

With ActiveChart.Axes(xlCategory)
.CrossesAt = 1
.TickLabelSpacing = 1
.TickMarkSpacing = 1
.AxisBetweenCategories = True
.ReversePlotOrder = False
End With
ActiveChart.ChartArea.Select
ActiveChart.HasLegend = True
ActiveChart.Legend.Select
Selection.Position = xlRight

ActiveChart.ChartArea.Select
ActiveSheet.Shapes("Diagramm 2").IncrementLeft -174.75
ActiveSheet.Shapes("Diagramm 2").IncrementTop -96.75

'***** GET DATA FROM WORKSHEET 1 ******
'**********TO WORKSHEET 2 *************
'**************************************
'#20
'active rows
For xRowActive& = xRowFirst& To xRowLast&

'data from wks1 to wks2
wks2.Cells(xRowActive&, xColOrigiNum&).value =
wks1.Cells(xRowActive&, xColOrigiName&).value
wks2.Cells(xRowActive&, xColOrigiName&).value =
wks1.Cells(xRowActive&, xColOrigiNum&).value
wks2.Cells(xRowActive&, xColDestNum2&).value =
wks1.Cells(xRowActive&, xColDestName&).value
wks2.Cells(xRowActive&, xColDestName2&).value =
wks1.Cells(xRowActive&, xColDestNum&).value
wks2.Cells(xRowActive&, xColStartDate2&).value =
wks1.Cells(xRowActive&, xColStartDate&).value
wks2.Cells(xRowActive&, xColStartTime2&).value =
wks1.Cells(xRowActive&, xColStartTime&).value

'take next caller name?
If Not xColOrigiNameValue = wks2.Cells(xRowActive&,
xColOrigiNum&).value Then

'still same caller name
xColOrigiNameValue = wks2.Cells(xRowActive&, xColOrigiNum&).value

End If

'costs
wks2.Cells(xRowActive&, xColCostsPerName&).NumberFormat =
"#,##0.00"
wks2.Cells(xRowActive&, xColCostsPerName&).value =
wks1.Cells(xRowActive&, xColCosts&).value

Next


'***** FORMAT DATA OF WORKSHEET 2 *****
'**************************************
'#21
wks2.Activate
wks2.Cells(1, 1).Select
ActiveCell.CurrentRegion.Select

'format headers bold and align middle
Selection.AutoFormat Format:=xlRangeAutoFormatSimple, Number:=True,
Font _
:=True, Alignment:=True, Border:=False, Pattern:=True,
Width:=True
Selection.Sort key1:=Cells(xRowFirst&, xColOrigiNum&),
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

'allow word-wrap
With Selection
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False

End With


'#22 calculate sum for each caller
Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(7,
8), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True

'freeze the headers, so you always see them while scrolling
Rows("2:2").Select
ActiveWindow.FreezePanes = True


'#23 print format for worksheet 1
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
End With
Application.ActiveWorkbook.Worksheets(1).Activate
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
'.CenterHeader = "&""Tahoma,Fett""&12Call Detail Records" &
Chr(10) & "&F " & Chr(10) & "" & Chr(10) & "" & Chr(10) & ""
.CenterHeader = "&""Tahoma,Fett""&12Call Detail Records" & "&F
" & "" & "" & ""
.RightHeader = ""
.LeftFooter = "&D &T"
.CenterFooter = "Seite &P von &N"
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.78740157480315)
.RightMargin = Application.InchesToPoints(0.78740157480315)
.TopMargin = Application.InchesToPoints(0.984251968503937)
.BottomMargin = Application.InchesToPoints(0.984251968503937)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 100
End With

'print format for worksheet 2
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
End With
Application.ActiveWorkbook.Worksheets(2).Activate
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
'.CenterHeader = "&""Tahoma,Fett""&12Call Detail Records" &
Chr(10) & "&F " & Chr(10) & "" & Chr(10) & "" & Chr(10) & ""
.CenterHeader = "&""Tahoma,Fett""&12Call Detail Records" & "&F
" & "" & "" & ""
.RightHeader = ""
.LeftFooter = "&D &T"
.CenterFooter = "Seite &P von &N"
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.78740157480315)
.RightMargin = Application.InchesToPoints(0.78740157480315)
.TopMargin = Application.InchesToPoints(0.984251968503937)
.BottomMargin = Application.InchesToPoints(0.984251968503937)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 100
End With


'hide dialog when CDR Files are loaded
LoadDialog.Label5.Visible = False
LoadDialog.Repaint
LoadDialog.Hide
LoadDialog.MousePointer = fmMousePointerDefault


'*******ERROR CODE*********************
'**************************************
'#24
Dim text, button, Titel, antwort, Mldg

' If Err.Number <> 0 Then
' Mldg = "Fehler # " & Str(Err.Number) & " wurde ausgelöst von " _
' & Err.Source & Chr(13) & Err.Description
' Mldg = "Fehler # " & Err.Number & " wurde ausgelöst von " _
' & Err.Source & Err.Description
' MsgBox Mldg, , "Fehler", Err.HelpFile, Err.HelpContext
' End If

Application.DisplayAlerts = True
Application.ScreenUpdating = True

wks1.Activate
End Sub

'***********SAVE DATA******************
'**************************************
'#25
Sub SaveData()

Dim xPath$

Selection:
CurrentDate = Application.text(Now(), "mm-dd-yy hh-mm")
Backup = "Backup" & CurrentDate
xPath$ = Application.GetSaveAsFilename(InitialFilename:=Backup,
fileFilter:="Backup (*.xls), *.xls")

ActiveWorkbook.SaveAs Filename:=xPath$, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False

MsgBox "Saving Call Detail Records: " & xPath$
ActiveWorkbook.Close

End Sub

From: mr_unreliable on 24 Jan 2006 15:45

---

hi Crumb,

It looks to me like your "vbs" code is more like "vba" code,
i.e., excel macro code.

If it is, then you might get a better answer in the excel
or vba code groups, found here:

news://microsoft.public.de.excel

news://microsoft.public.excel.programming

news://microsoft.public.office.developer.vba

cheers, jw


Crumb wrote:
> Hi,
>
> I have a problem with a German VB file which I am sure is related to
> the time and date format used in the UK dd.mm.yyyy
>
> If i sent my PC to location Germany then the code works.
>

 | 
Pages: 1
Prev: Find out where a user is logged in?
Next: objDSO.OpenDSObject Query from workgroup computer............