German VBA Problem

C

Crumb

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


'**************************************
'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)
....

read more
 
J

Jim Cone

C,

You will have to provide some or all of the following
information to get someone to try and help.

What is the problem that occurs?
What code line generates the error?
What is the error number and message?
What is the Excel version and operating system version?

Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware


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


'**************************************
'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)
....

read more
 
J

Jim Cone

C,
Sorry but I will have to pass on this one.
Jim Cone

Can I send you the xla sheet along with some data?
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

InputBox for column letter problem 2
first sip of working with range in vba excel 6
VBA-Table Word 2019 - Move a selected text, from a cell to the adjacent cell to its right, by pressing the ENTER key 0
New to userforms - can you help with this code? 10
Compile error: End If without block IF 1
Speeding up macros 4
424 error on a Worksheet Change Macro 2
WORD VBA Search and switch to advanced ... 1

Top