-
-
Notifications
You must be signed in to change notification settings - Fork 8
Expand file tree
/
Copy pathConversion.vb
More file actions
1095 lines (882 loc) · 32.8 KB
/
Conversion.vb
File metadata and controls
1095 lines (882 loc) · 32.8 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
' Licensed to the .NET Foundation under one or more agreements.
' The .NET Foundation licenses this file to you under the MIT license.
Imports System
Imports System.Runtime.Versioning
Imports Community.VisualBasic.CompilerServices
Imports Community.VisualBasic.CompilerServices.ExceptionUtils
Imports Community.VisualBasic.CompilerServices.Utils
Namespace Global.Community.VisualBasic
Public Module Conversion
Private Const NUMPRS_LEADING_PLUS As Integer = &H4I
Private Const NUMPRS_LEADING_MINUS As Integer = &H10I
Private Const NUMPRS_HEX_OCT As Integer = &H40I
Private Const NUMPRS_DECIMAL As Integer = &H100I
Private Const NUMPRS_EXPONENT As Integer = &H800I
' flags used by VarNumFromParseNum to indicate acceptable result types:
'
Private Const VTBIT_I2 As Integer = &H4
Private Const VTBIT_I4 As Integer = &H8
Private Const VTBIT_R4 As Integer = &H10
Private Const VTBIT_R8 As Integer = &H20
Private Const VTBIT_DATE As Integer = &H80
Private Const VTBIT_BSTR As Integer = &H100
Private Const VTBIT_OBJECT As Integer = &H200
Private Const VTBIT_ERROR As Integer = &H400
Private Const VTBIT_BOOL As Integer = &H800
Private Const VTBIT_VARIANT As Integer = &H1000
Private Const VTBIT_DATAOBJECT As Integer = &H2000
Private Const VTBIT_DECIMAL As Integer = &H4000
Private Const VTBIT_BYTE As Integer = &H20000
Private Const VTBIT_CHAR As Integer = &H40000
Private Const VTBIT_LONG As Integer = &H100000
Private Const LOCALE_NOUSEROVERRIDE As Integer = &H80000000I
Private Const LCID_US_ENGLISH As Integer = &H409I
Private Const PRSFLAGS As Integer = (NUMPRS_LEADING_PLUS Or NUMPRS_LEADING_MINUS Or NUMPRS_HEX_OCT Or NUMPRS_DECIMAL Or NUMPRS_EXPONENT)
Private Const VTBITS As Integer = (VTBIT_I2 Or VTBIT_I4 Or VTBIT_R8 Or VTBIT_DECIMAL)
Private Const MAX_ERR_NUMBER As Integer = 65535
Private Const TYPE_INDICATOR_INT16 As Char = "%"c
Private Const TYPE_INDICATOR_INT32 As Char = "&"c
Private Const TYPE_INDICATOR_SINGLE As Char = "!"c
Private Const TYPE_INDICATOR_DECIMAL As Char = "@"c
'============================================================================
' Error message functions.
'============================================================================
Public Function ErrorToString() As String
Return Information.Err().Description
End Function
Public Function ErrorToString(ErrorNumber As Integer) As String
If ErrorNumber >= MAX_ERR_NUMBER Then
Throw New ArgumentException(SR.MaxErrNumber)
End If
If ErrorNumber > 0 Then
ErrorNumber = (SEVERITY_ERROR Or FACILITY_CONTROL Or ErrorNumber)
End If
If (ErrorNumber And SCODE_FACILITY) = FACILITY_CONTROL Then
ErrorNumber = ErrorNumber And &HFFFFI
Return GetResourceString(CType(ErrorNumber, vbErrors))
ElseIf ErrorNumber <> 0 Then
Return GetResourceString(vbErrors.UserDefined)
Else
Return ""
End If
End Function
'============================================================================
' Numeric functions.
'============================================================================
Public Function Fix(number As Short) As Short
Return number
End Function
Public Function Fix(number As Integer) As Integer
Return number
End Function
Public Function Fix(number As Long) As Long
Return number
End Function
Public Function Fix(number As Double) As Double
If number >= 0 Then
Return System.Math.Floor(number)
Else
Return -System.Math.Floor(-number)
End If
End Function
Public Function Fix(number As Single) As Single
If number >= 0 Then
Return CSng(System.Math.Floor(CDbl(number)))
Else
Return CSng(-System.Math.Floor(CDbl(-number)))
End If
End Function
Public Function Fix(number As Decimal) As Decimal
If System.Decimal.op_LessThan(number, System.Decimal.Zero) Then
Return System.Decimal.Negate(System.Decimal.Floor(System.Decimal.Negate(number)))
Else
Return System.Decimal.Floor(number)
End If
End Function
Public Function Fix(number As Object) As Object
If number Is Nothing Then
Throw New ArgumentNullException(SR.Format(SR.Argument_InvalidNullValue1, "Number"))
End If
Dim ValueInterface As IConvertible
ValueInterface = TryCast(number, IConvertible)
If ValueInterface IsNot Nothing Then
Select Case ValueInterface.GetTypeCode()
Case TypeCode.SByte,
TypeCode.Byte,
TypeCode.Int16,
TypeCode.UInt16,
TypeCode.Int32,
TypeCode.UInt32,
TypeCode.Int64,
TypeCode.UInt64
Return number
Case TypeCode.Single
Return Fix(ValueInterface.ToSingle(Nothing))
Case TypeCode.Double
Return Fix(ValueInterface.ToDouble(Nothing))
Case TypeCode.Decimal
Return Fix(ValueInterface.ToDecimal(Nothing))
Case TypeCode.Boolean
Return ValueInterface.ToInt32(Nothing)
Case TypeCode.String
Return Fix(CDbl(ValueInterface.ToString(Nothing)))
Case Else
'TypeCode.Char
'TypeCode.DateTime
' Fall through to error
End Select
End If
Throw VbMakeException(New ArgumentException(SR.Format(SR.Argument_NotNumericType2, NameOf(number), number.GetType().FullName)), vbErrors.TypeMismatch)
End Function
Public Function Int(number As Short) As Short
Return number
End Function
Public Function Int(number As Integer) As Integer
Return number
End Function
Public Function Int(number As Long) As Long
Return number
End Function
Public Function Int(number As Double) As Double
Return System.Math.Floor(number)
End Function
Public Function Int(number As Single) As Single
Return CSng(System.Math.Floor(CDbl(number)))
End Function
Public Function Int(number As Decimal) As Decimal
Return System.Decimal.Floor(number)
End Function
Public Function Int(number As Object) As Object
If number Is Nothing Then
Throw New ArgumentNullException(SR.Format(SR.Argument_InvalidNullValue1, NameOf(number)))
End If
Dim ValueInterface As IConvertible
ValueInterface = TryCast(number, IConvertible)
If ValueInterface IsNot Nothing Then
Select Case ValueInterface.GetTypeCode()
Case TypeCode.SByte,
TypeCode.Byte,
TypeCode.Int16,
TypeCode.UInt16,
TypeCode.Int32,
TypeCode.UInt32,
TypeCode.Int64,
TypeCode.UInt64
Return number
Case TypeCode.Single
Return Int(ValueInterface.ToSingle(Nothing))
Case TypeCode.Double
Return Int(ValueInterface.ToDouble(Nothing))
Case TypeCode.Decimal
Return Int(ValueInterface.ToDecimal(Nothing))
Case TypeCode.Boolean
Return ValueInterface.ToInt32(Nothing)
Case TypeCode.String
Return Int(CDbl(ValueInterface.ToString(Nothing)))
Case Else
'TypeCode.Char
'TypeCode.DateTime
' Fall through to error
End Select
End If
Throw VbMakeException(New ArgumentException(SR.Format(SR.Argument_NotNumericType2, NameOf(number), number.GetType().FullName)), vbErrors.TypeMismatch)
End Function
'============================================================================
' Number to string conversion
'============================================================================
<CLSCompliant(False)>
Public Function Hex(number As SByte) As String
Return number.ToString("X")
End Function
Public Function Hex(number As Byte) As String
Return number.ToString("X")
End Function
Public Function Hex(number As Short) As String
Return number.ToString("X")
End Function
<CLSCompliant(False)>
Public Function Hex(number As UShort) As String
Return number.ToString("X")
End Function
Public Function Hex(number As Integer) As String
Return number.ToString("X")
End Function
<CLSCompliant(False)>
Public Function Hex(number As UInteger) As String
Return number.ToString("X")
End Function
Public Function Hex(number As Long) As String
Return number.ToString("X")
End Function
<CLSCompliant(False)>
Public Function Hex(number As ULong) As String
Return number.ToString("X")
End Function
Public Function Hex(number As Object) As String
Dim longValue As Long
If number Is Nothing Then
Throw New ArgumentNullException(SR.Format(SR.Argument_InvalidNullValue1, NameOf(number)))
End If
Dim valueInterface = TryCast(number, IConvertible)
If valueInterface IsNot Nothing Then
Select Case valueInterface.GetTypeCode()
Case TypeCode.SByte : Return Hex(valueInterface.ToSByte(Nothing))
Case TypeCode.Byte : Return Hex(valueInterface.ToByte(Nothing))
Case TypeCode.Int16 : Return Hex(valueInterface.ToInt16(Nothing))
Case TypeCode.UInt16 : Return Hex(valueInterface.ToUInt16(Nothing))
Case TypeCode.Int32 : Return Hex(valueInterface.ToInt32(Nothing))
Case TypeCode.UInt32 : Return Hex(valueInterface.ToUInt32(Nothing))
Case TypeCode.Int64,
TypeCode.Single,
TypeCode.Double,
TypeCode.Decimal
longValue = valueInterface.ToInt64(Nothing)
GoTo RangeCheck
Case TypeCode.UInt64 : Return Hex(valueInterface.ToUInt64(Nothing))
Case TypeCode.String
Try
longValue = CLng(valueInterface.ToString(Nothing))
Catch ex As OverflowException
'If the conversion to Long overflows, we can try ULong.
Return Hex(CULng(valueInterface.ToString(Nothing)))
End Try
RangeCheck:
'Optimization case
If longValue = 0 Then
Return "0"
End If
If longValue > 0 Then
Return Hex(longValue)
Else
'For VB6 compatability, format as Int32 value
' unless it overflows into an Int64
If longValue >= System.Int32.MinValue Then
Return Hex(CInt(longValue))
End If
Return Hex(longValue)
End If
Case TypeCode.Boolean,
TypeCode.Char,
TypeCode.DateTime
' Fall through to error
Case Else
' Fall through to error
End Select
End If
Throw New ArgumentException(SR.Format(SR.Argument_InvalidValueType2, NameOf(number), VBFriendlyName(number)))
End Function
<CLSCompliant(False)>
Public Function Oct(number As SByte) As String
Return OctFromLong(CLng(number) And &HFFL)
End Function
Public Function Oct(number As Byte) As String
Return OctFromULong(CULng(number))
End Function
Public Function Oct(number As Short) As String
Return OctFromLong(CLng(number) And &HFFFFL)
End Function
<CLSCompliant(False)>
Public Function Oct(number As UShort) As String
Return OctFromULong(CULng(number))
End Function
Public Function Oct(number As Integer) As String
Return OctFromLong(CLng(number) And &HFFFFFFFFL)
End Function
<CLSCompliant(False)>
Public Function Oct(number As UInteger) As String
Return OctFromULong(CULng(number))
End Function
Public Function Oct(number As Long) As String
Return OctFromLong(number)
End Function
<CLSCompliant(False)>
Public Function Oct(number As ULong) As String
Return OctFromULong(number)
End Function
Public Function Oct(number As Object) As String
Dim LongValue As Long
If number Is Nothing Then
Throw New ArgumentNullException(SR.Format(SR.Argument_InvalidNullValue1, NameOf(number)))
End If
Dim ValueInterface As IConvertible
ValueInterface = TryCast(number, IConvertible)
If ValueInterface IsNot Nothing Then
Select Case ValueInterface.GetTypeCode()
Case TypeCode.SByte
Return Oct(ValueInterface.ToSByte(Nothing))
Case TypeCode.Byte
Return Oct(ValueInterface.ToByte(Nothing))
Case TypeCode.Int16
Return Oct(ValueInterface.ToInt16(Nothing))
Case TypeCode.UInt16
Return Oct(ValueInterface.ToUInt16(Nothing))
Case TypeCode.Int32
Return Oct(ValueInterface.ToInt32(Nothing))
Case TypeCode.UInt32
Return Oct(ValueInterface.ToUInt32(Nothing))
Case TypeCode.Int64,
TypeCode.Single,
TypeCode.Double,
TypeCode.Decimal
LongValue = ValueInterface.ToInt64(Nothing)
GoTo RangeCheck
Case TypeCode.UInt64
Return Oct(ValueInterface.ToUInt64(Nothing))
Case TypeCode.String
Try
LongValue = CLng(ValueInterface.ToString(Nothing))
Catch ex As OverflowException
'If the conversion to Long overflows, we can try ULong.
Return Oct(CULng(ValueInterface.ToString(Nothing)))
End Try
RangeCheck:
'Optimization case
If LongValue = 0 Then
Return "0"
End If
If (LongValue > 0) Then
Return Oct(LongValue)
Else
'For VB6 compatability, format as Int32 value
' unless it overflows into an Int64
If (LongValue >= System.Int32.MinValue) Then
Return Oct(CInt(LongValue))
End If
Return Oct(LongValue)
End If
Case TypeCode.Boolean,
TypeCode.Char,
TypeCode.DateTime
' Fall through to error
Case Else
' Fall through to error
End Select
End If
Throw New ArgumentException(SR.Format(SR.Argument_InvalidValueType2, NameOf(number), VBFriendlyName(number)))
End Function
Public Function Str(Number As Object) As String
Dim s As String
If Number Is Nothing Then
Throw New ArgumentNullException(SR.Format(SR.Argument_InvalidNullValue1, NameOf(Number)))
End If
Dim ValueInterface As IConvertible
Dim ValueTypeCode As TypeCode
ValueInterface = TryCast(Number, IConvertible)
If ValueInterface Is Nothing Then
Throw New InvalidCastException(SR.Format(SR.ArgumentNotNumeric1, NameOf(Number)))
End If
ValueTypeCode = ValueInterface.GetTypeCode()
Select Case ValueTypeCode
Case TypeCode.DBNull
Return "Null"
Case TypeCode.Boolean
If ValueInterface.ToBoolean(Nothing) Then
Return "True"
Else
Return "False"
End If
Case TypeCode.SByte,
TypeCode.Byte,
TypeCode.Int16,
TypeCode.UInt16,
TypeCode.Int32,
TypeCode.UInt32,
TypeCode.Int64,
TypeCode.UInt64,
TypeCode.Single,
TypeCode.Double,
TypeCode.Decimal
s = CStr(Number)
Case Else
If ValueTypeCode = TypeCode.String Then
Try
s = CStr(CDbl(ValueInterface.ToString(Nothing)))
GoTo FormatAndExit
Catch ex As StackOverflowException
Throw ex
Catch ex As OutOfMemoryException
Throw ex
Catch
'Throw our own exception below
End Try
End If
Throw New InvalidCastException(SR.Format(SR.ArgumentNotNumeric1, NameOf(Number)))
End Select
FormatAndExit:
If s.Length > 0 AndAlso s.Chars(0) <> "-"c Then
Return " " & StdFormat(s)
Else
Return StdFormat(s)
End If
End Function
Private Function HexOrOctValue(InputStr As String, i As Integer) As Double
Dim digits As Integer = 0
Dim ch As Char
Dim iLen As Integer
Dim ivalue As Long
Dim digitValue As Integer
Const asc0 As Integer = AscW("0"c)
Const ascUpperAoffset As Integer = AscW("A"c) - 10
Const ascLowerAoffset As Integer = AscW("a"c) - 10
iLen = InputStr.Length
ch = InputStr.Chars(i)
i += 1
If ch = "H"c OrElse ch = "h"c Then
'Loop for octal
Do While (i < iLen AndAlso digits < 17)
ch = InputStr.Chars(i)
i += 1
Select Case ch
Case ControlChars.Tab, ControlChars.Lf, ControlChars.Cr, ChrW(32), ChrW(&H3000S)
GoTo NextHexCharacter
Case "0"c
If digits = 0 Then
'leading zeros do not affect type
GoTo NextHexCharacter
End If
digitValue = 0
Case "1"c To "9"c
digitValue = AscW(ch) - asc0
Case "A"c To "F"c
digitValue = AscW(ch) - ascUpperAoffset
Case "a"c To "f"c
digitValue = AscW(ch) - ascLowerAoffset
Case Else
Exit Do
End Select
AddHexDigit:
' If digits = 15 AndAlso ivalue >= &H800000000000000L Then
If digits = 15 AndAlso ivalue > &H7FFFFFFFFFFFFFFL Then
'This will overflow because we don't have a shift operator
'and must do multiplication
ivalue = (ivalue And &H7FFFFFFFFFFFFFFL) * 16
ivalue = ivalue Or &H8000000000000000L
Else
ivalue *= 16
End If
ivalue += digitValue
digits += 1
NextHexCharacter:
Loop
If digits = 16 Then
i += 1
If i < iLen Then
'We fell out of the loop before getting the typechar
ch = InputStr.Chars(i)
End If
End If
If digits > 8 Then
'leave ivalue unchanged
ElseIf digits > 4 OrElse ch = TYPE_INDICATOR_INT32 Then
If ivalue > &H7FFFFFFFL Then
ivalue = Int32.MinValue + (ivalue And &H7FFFFFFFL)
End If
ElseIf digits > 2 OrElse ch = TYPE_INDICATOR_INT16 Then
If ivalue > &H7FFFL Then
ivalue = Int16.MinValue + (ivalue And &H7FFFL)
End If
End If
If ch = TYPE_INDICATOR_INT16 Then
ivalue = CShort(ivalue)
ElseIf ch = TYPE_INDICATOR_INT32 Then
ivalue = CInt(ivalue)
End If
Return ivalue
ElseIf ch = "O"c OrElse ch = "o"c Then
'Loop for octal
Do While (i < iLen AndAlso digits < 22)
ch = InputStr.Chars(i)
i += 1
Select Case ch
Case ControlChars.Tab, ControlChars.Lf, ControlChars.Cr, ChrW(32), ChrW(&H3000S)
GoTo NextOctCharacter
Case "0"c
If digits = 0 Then
'leading zeros do not affect type
GoTo NextOctCharacter
End If
digitValue = 0
Case "1"c To "7"c
digitValue = AscW(ch) - asc0
Case Else
Exit Do
End Select
AddOctDigit:
If ivalue >= &O100000000000000000000L Then
'This will overflow because we don't have a shift operator
'and must do multiplication
ivalue = (ivalue And &O77777777777777777777L) * 8
ivalue = ivalue Or &O100000000000000000000L
Else
ivalue *= 8
End If
ivalue += digitValue
digits += 1
NextOctCharacter:
Loop
If digits = 22 Then
i += 1
If i < iLen Then
'We fell out of the loop before getting the typechar
ch = InputStr.Chars(i)
End If
End If
If ivalue > &H100000000L Then
'leave ivalue unchanged
ElseIf ivalue > &HFFFFL OrElse ch = TYPE_INDICATOR_INT32 Then
If ivalue > &H7FFFFFFFL Then
ivalue = Int32.MinValue + (ivalue And &H7FFFFFFFL)
End If
ElseIf ivalue > &HFFL OrElse ch = TYPE_INDICATOR_INT16 Then
If ivalue > &H7FFFL Then
ivalue = Int16.MinValue + (ivalue And &H7FFFL)
End If
End If
If ch = TYPE_INDICATOR_INT16 Then
ivalue = CShort(ivalue)
ElseIf ch = TYPE_INDICATOR_INT32 Then
ivalue = CInt(ivalue)
End If
Return ivalue
Else
'input is invalid
Return 0
End If
End Function
Public Function Val(InputStr As String) As Double
Dim ch As Char
Dim i As Integer
Dim iLen As Integer
Dim digits As Integer
Dim digitsAfterDecimal, digitsBeforeDecimal As Integer
Const asc0 As Integer = AscW("0"c)
If InputStr Is Nothing Then
iLen = 0
Else
iLen = InputStr.Length
End If
i = 0
'Skip over leading whitespace
Do While (i < iLen)
ch = InputStr.Chars(i)
Select Case ch
Case ControlChars.Tab, ControlChars.Lf, ControlChars.Cr, ChrW(32), ChrW(&H3000S)
i += 1
Case Else
Exit Do
End Select
Loop
If i >= iLen Then
Return 0
End If
ch = InputStr.Chars(i)
If ch = "&"c Then 'We are dealing with hex or octal numbers
Return HexOrOctValue(InputStr, i + 1)
Else 'we are dealing with base 10 decimal
Dim value As Double
Dim afterdecimal As Boolean = False
Dim aftere As Boolean = False
Dim negative As Boolean = False
Dim eval As Double = 0
'Check for negative
ch = InputStr.Chars(i)
If ch = "-"c Then
negative = True
i += 1
ElseIf ch = "+"c Then
i += 1
End If
'check for numbers before a decimal or E
Do While (i < iLen)
ch = InputStr.Chars(i)
Select Case ch
Case ControlChars.Tab, ControlChars.Lf, ControlChars.Cr, ChrW(32), ChrW(&H3000S)
i += 1
Case "0"c
If digits <> 0 OrElse afterdecimal Then
value = value * 10 + AscW(ch) - asc0
i += 1
digits += 1
Else
i += 1
'don't count as digit
End If
Case "1"c To "9"c
value = value * 10 + AscW(ch) - asc0
i += 1
digits += 1
Case "."c
i += 1
If afterdecimal = False Then
afterdecimal = True
digitsBeforeDecimal = digits
Else
'handle "1..1" or "1.2.1"
Exit Do
End If
Case "e"c, "E"c, "d"c, "D"c
aftere = True
i += 1
Exit Do
Case Else
Exit Do
End Select
Loop
If afterdecimal Then
digitsAfterDecimal = digits - digitsBeforeDecimal
End If
If aftere Then
Dim afterplusminus As Boolean = False
Dim enegative As Boolean = False
Do While (i < iLen)
ch = InputStr.Chars(i)
Select Case ch
Case ControlChars.Tab, ControlChars.Lf, ControlChars.Cr, ChrW(32), ChrW(&H3000S)
i += 1
Case "0"c To "9"c
eval = eval * 10 + AscW(ch) - asc0
i += 1
Case "+"c
If Not afterplusminus Then
afterplusminus = True
i += 1
Else
Exit Do
End If
Case "-"c
If Not afterplusminus Then
afterplusminus = True
enegative = True
i += 1
Else
Exit Do
End If
Case Else
Exit Do
End Select
Loop
If enegative Then
eval += digitsAfterDecimal
value *= (10 ^ (-eval))
Else
eval -= digitsAfterDecimal
value *= (10 ^ (eval))
End If
Else
If afterdecimal AndAlso digitsAfterDecimal <> 0 Then
'Need to adjust for decimal
value /= (10 ^ digitsAfterDecimal)
End If
End If
If System.Double.IsInfinity(value) Then
Throw VbMakeException(vbErrors.Overflow)
End If
If negative Then
value = -value
End If
Select Case ch
Case TYPE_INDICATOR_INT16
If digitsAfterDecimal > 0 Then
Throw VbMakeException(vbErrors.TypeMismatch)
End If
value = CShort(value)
Case TYPE_INDICATOR_INT32
If digitsAfterDecimal > 0 Then
Throw VbMakeException(vbErrors.TypeMismatch)
End If
value = CInt(value)
Case TYPE_INDICATOR_SINGLE
value = CSng(value)
Case TYPE_INDICATOR_DECIMAL
value = CDec(value)
Case Else
End Select
Return value
End If
End Function
Public Function Val(Expression As Char) As Integer
'Val only handles Ascii decimal chars '0' to '9'
Dim CharValue As Integer
CharValue = AscW(Expression) 'CType(Expression, IConvertible).ToInt32(Nothing)
If CharValue >= AscW("1"c) AndAlso CharValue <= AscW("9"c) Then
Return CharValue - AscW("0")
End If
Return 0
End Function
Public Function Val(Expression As Object) As Double
Dim StringExpression As String = TryCast(Expression, String)
If StringExpression IsNot Nothing Then
Return Val(StringExpression)
ElseIf TypeOf Expression Is Char Then
Return Val(DirectCast(Expression, Char))
ElseIf CompilerServices.Versioned.IsNumeric(Expression) Then
Return CDbl(Expression)
Else
Dim sValue As String
Try
sValue = CStr(Expression)
Catch ex As StackOverflowException
Throw ex
Catch ex As OutOfMemoryException
Throw ex
Catch
Throw VbMakeException(New ArgumentException(SR.Format(SR.Argument_InvalidValueType2, NameOf(Expression), VBFriendlyName(Expression))), vbErrors.OLENoPropOrMethod)
End Try
Return Val(sValue)
End If
End Function
<ResourceExposure(ResourceScope.None)>
<ResourceConsumption(ResourceScope.Machine, ResourceScope.Machine)>
Friend Function ParseInputField(Value As Object, vtInput As VariantType) As Object
If OperatingSystem.IsWindows Then
Dim numprsPtr() As Byte
Dim vtSuffix As Integer
Dim cDecMax As Integer
Dim StringValue As String = CStr(Value)
Dim DigitArray() As Byte
Dim pd As ProjectData
Dim cchUsed As Int32
Dim nPwr10 As Int32
Dim chTypeChar As Char
Dim dwOutFlags As Int32
Dim nBaseShift As Int32
Const INTEGER_SIZE As Integer = 4
Const INFLAGS_OFFSET As Integer = 4
If ((vtInput = VariantType.Empty) AndAlso ((Value Is Nothing) OrElse Len(CStr(Value)) = 0)) Then
Return Nothing
End If
pd = ProjectData.GetProjectData()
numprsPtr = pd.m_numprsPtr
DigitArray = pd.m_DigitArray
'numprsPtr is actually a struct. The first two fields are cDig (the size of the digits array)
'and dwInFlags which we set to PRSFLAGS
'Init NUMPARSE.cDig
Array.Copy(BitConverter.GetBytes(Convert.ToInt32(DigitArray.Length)), 0, numprsPtr, 0, INTEGER_SIZE)
'Init NUMPARSE.dwInFlags
Array.Copy(BitConverter.GetBytes(Convert.ToInt32(PRSFLAGS)), 0, numprsPtr, INFLAGS_OFFSET, INTEGER_SIZE)
' For file interchangeability, we always use US decimal.
If UnsafeNativeMethods.VarParseNumFromStr(StringValue, LCID_US_ENGLISH, LOCALE_NOUSEROVERRIDE, numprsPtr, DigitArray) < 0 Then
If (vtInput <> VariantType.Empty) Then
' Just return 0 if we don't understand the number
Return 0
End If
Return StringValue
End If
' Look for type character following string
dwOutFlags = BitConverter.ToInt32(numprsPtr, 8)
cchUsed = BitConverter.ToInt32(numprsPtr, 12)
nBaseShift = BitConverter.ToInt32(numprsPtr, 16)
nPwr10 = BitConverter.ToInt32(numprsPtr, 20)
If cchUsed < StringValue.Length Then
chTypeChar = StringValue.Chars(cchUsed)
End If
Select Case (chTypeChar)
Case "%"c
vtSuffix = VariantType.Short
cDecMax = 0
Case "&"c
vtSuffix = VariantType.Integer
cDecMax = 0
Case "@"c
'Convert currency to Decimal
'vtSuffix = VariantType.Currency
vtSuffix = VariantType.Decimal
cDecMax = 4
Case "!"c
If (vtInput = VariantType.Double) Then
vtSuffix = VariantType.Double
Else
vtSuffix = VariantType.Single
End If
cDecMax = System.Int32.MaxValue
Case "#"c
vtSuffix = VariantType.Double
cDecMax = System.Int32.MaxValue
Case Else
' No type suffix.
If (vtInput = VariantType.Empty) Then
' no indication of type, either from suffix or defined
' by type we're inputting to.
Dim dwVtBits As Integer = VTBITS
If (dwOutFlags And NUMPRS_EXPONENT) <> 0 Then
' if exponent specified, result is R8 only.