راه حل pdu کردن پیفام sms
البته باید از دوست عزیزم دانیال تشکر کنم که در این زمینه کمکم کرد
http://www.gsm-modem.de/sms-pdu-mode.html
Class pduss
Public Function IsValidPhone(ByVal PhoneNo As String) As Boolean
IsValidPhone = False
Dim S As String
S = PhoneNo
If Len(S) < 3 Or Len(S) > 20 Then Exit Function
Dim L As Integer
If Left(PhoneNo, 1) = "+" Then S = Right(PhoneNo, Len(PhoneNo) - 1)
For L = 1 To Len(S)
If Not ((IsNumeric(Mid(S, L, 1))) Or (Mid(S, L, 1) = "p")) Then Exit Function
Next
IsValidPhone = True
End Function
Public Function Is7Bit(ByVal Str As String) As Boolean
Dim S As String
Dim L As Integer
Dim L2 As Long
Dim B As Boolean
Is7Bit = False
If Str = "" Then Exit Function
If IsUTF8(Str) Then
B = False
For L = 1 To Len(Str)
If Not (B) Then
S = Mid(Str, L, 1)
L2 = (AscW(S) And &H80)
If L2 <> 0 Then B = True
End If ' if not b
Next
Is7Bit = Not (B)
End If
End Function
Public Function IsUTF8(ByVal Str As String) As Boolean
Dim S As String
Dim L As Integer
Dim L2 As Long
Dim B As Boolean
IsUTF8 = False
If Str = "" Then Exit Function
B = False
For L = 1 To Len(Str)
'If Not (B) Then
S = Mid(Str, L, 1)
If AscW(S) < 0 Then Exit Function
L2 = (AscW(S) And &HFF00) \ &H100
If L2 <> 0 Then Exit Function
'End If ' if not b
Next
IsUTF8 = True
End Function
Public Function IsHexDigit(ByVal Str As String) As Boolean
Dim S As String
Dim L As Integer
Dim B As Boolean
Dim B2 As Boolean
IsHexDigit = False
If Str = "" Then Exit Function
B = False
For L = 1 To Len(Str)
If Not (B) Then
S = Mid(Str, L, 1)
B2 = False
If (Asc(S) >= Asc("0")) And (Asc(S) <= Asc("9")) Then B2 = True
If (Asc(UCase(S)) >= Asc("A")) And (Asc(UCase(S)) <= Asc("F")) Then B2 = True
B = Not (B2)
End If ' if not b
Next
IsHexDigit = Not (B)
End Function
Public Function HexChar(ByVal N As Long) As String
If (Len(Hex(N)) Mod 2 <> 0) Then HexChar = "0" & Hex(N) Else HexChar = Hex(N)
End Function
Public Function Char2Hex(ByVal Str As String) As String
Dim S As String
Dim hs As Long
Dim H As Long
Dim L As Long
Char2Hex = ""
If Str = "" Then Exit Function
S = Mid(Str, 1, 1)
hs = AscW(S)
If hs < 0 Then hs = &H10000 + hs
H = (hs And &HFF00) \ &H100
L = hs And &HFF
Char2Hex = HexChar(H) & HexChar(L)
'Char2Hex = HexChar(AscW(S))
End Function
Public Function Phone_IsUCS(ByVal S As String) As Boolean
If Len(S) < 10 Then
Phone_IsUCS = False
Exit Function
End If
If (Left(S, 2) = "80") And (UCase(Right(S, 4)) = "FFFF") Then
Phone_IsUCS = IsHexDigit(S)
Else
Phone_IsUCS = False
End If
End Function
Public Function Phone_Str2UCS(ByVal Str As String) As String
'add 80 & ffff
Dim S As String
Dim L As Integer
Phone_Str2UCS = ""
S = ""
If Str = "" Then Exit Function
For L = 1 To Len(Str)
S = S & Char2Hex(Mid(Str, L, 1))
Next
Phone_Str2UCS = "80" & S & "FFFF"
End Function
Public Function HexDigitVal(ByVal H As String) As Integer
HexDigitVal = 0
If (Len(H) > 1) Or (H = "") Then Exit Function
If Not IsHexDigit(H) Then Exit Function
Select Case H
Case "0" : HexDigitVal = 0
Case "1" : HexDigitVal = 1
Case "2" : HexDigitVal = 2
Case "3" : HexDigitVal = 3
Case "4" : HexDigitVal = 4
Case "5" : HexDigitVal = 5
Case "6" : HexDigitVal = 6
Case "7" : HexDigitVal = 7
Case "8" : HexDigitVal = 8
Case "9" : HexDigitVal = 9
Case "A" : HexDigitVal = 10
Case "B" : HexDigitVal = 11
Case "C" : HexDigitVal = 12
Case "D" : HexDigitVal = 13
Case "E" : HexDigitVal = 14
Case "F" : HexDigitVal = 15
End Select
End Function
Public Function HexChar2Char(ByVal H As String) As String
HexChar2Char = ""
Dim S As String
Dim L As Long
Dim Lp As Integer
If Not IsHexDigit(H) Then Exit Function
If Len(H) <> 4 Then Exit Function
L = 0
For Lp = 1 To 4
L = L * &H10
L = L + HexDigitVal(Mid(H, Lp, 1))
Next
HexChar2Char = ChrW(L)
End Function
Public Function Phone_UCS2Str(ByVal S As String) As String
'strip off 80 & ffff
Phone_UCS2Str = ""
If Not Phone_IsUCS(S) Then Exit Function
Dim St As String
St = Left(S, Len(S) - 4) 'strip ffff
St = Right(St, Len(St) - 2) 'strp 80
Dim L As Integer
Dim Done As Boolean
Dim Str As String
Done = False
L = 0
Str = ""
While Not Done
Str = Str & HexChar2Char(Mid(St, 1 + L, 4))
L = L + 4
If L > Len(St) Then Done = True
End While
Phone_UCS2Str = Str
End Function
'PDU Functions....
Public Function Make7Bit2Octet(ByVal Str As String) As String
Dim L As Integer
Dim NextChar As Integer
Dim S As String
Dim Res As String
Dim cd As Integer
Dim ch1 As Integer
Dim ch2 As Integer
Dim Lp As Integer
Dim cnt As Integer
Dim AndNum As Integer
Dim OrNum As Integer
Dim OredMask As Integer
Make7Bit2Octet = ""
If Str = "" Then Exit Function
AndNum = &H7F
OrNum = &H1
OredMask = 0
Res = ""
cnt = 1
For L = 1 To Len(Str)
If L = Len(Str) Then NextChar = 0 Else NextChar = AscW(Mid(Str, L + 1, 1))
S = Mid(Str, L, 1)
ch1 = (AndNum And AscW(S)) 'used asc earlier
For Lp = 1 To cnt - 1
ch1 = ch1 \ 2
Next
OredMask = OredMask Or OrNum
ch2 = OredMask And NextChar
For Lp = 1 To (8 - cnt)
ch2 = ch2 * 2
Next
cd = ch2 Or ch1
Res = Res & HexChar(cd) 'hexchar should convert number to hex
'AndNum = AndNum \ 2 ' integer divide instead of /
OrNum = OrNum * 2
cnt = cnt + 1
If cnt = 8 Then
'AndNum = &H7F
OrNum = &H1
OredMask = 0
cnt = 1
L = L + 1
End If
Next
Make7Bit2Octet = Res
End Function
Public Function GetSemiOctet(ByVal Str As String) As String
'assumes input is digits string only
Dim S As String
Dim L As Integer
Dim Res As String
GetSemiOctet = ""
If Str = "" Then Exit Function
S = Str
Res = ""
If (Len(Str) Mod 2) <> 0 Then S = S & "F"
For L = 1 To Len(S) Step 2
Res = Res & Mid(S, L + 1, 1) & Mid(S, L, 1)
Next
GetSemiOctet = Res
End Function
Public Function MakeOctetTo7Bit(ByVal Str As String) As String
Dim Res As String
Dim S As String
Dim PrevChar As Integer
Dim CurChar As Integer
Dim L As Integer
Dim ch1 As Integer
Dim ch2 As Integer
Dim AndNum As Integer
Dim cnt As Integer
Dim Lp As Integer
MakeOctetTo7Bit = ""
If (Str = "") Or (Len(Str) Mod 2 <> 0) Then Exit Function
S = ""
For L = 1 To Len(Str) Step 2
'make char string s of characters
S = S & ChrW(HexDigitVal(Mid(Str, L, 1)) * &H10 + HexDigitVal(Mid(Str, L + 1, 1)))
'previously used chr
Next
Res = ""
AndNum = &H7F
PrevChar = 0
cnt = 1
For L = 1 To Len(S)
ch1 = AscW(Mid(S, L, 1)) And AndNum
For Lp = 1 To cnt - 1
ch1 = ch1 * 2
Next
'Ormask = Ormask Or OrNum
If L = 1 Then PrevChar = 0 Else PrevChar = AscW(Mid(S, L - 1, 1))
If cnt = 1 Then
ch2 = 0
Else
ch2 = PrevChar And ((Not (AndNum)) * 2)
For Lp = 1 To (9 - cnt)
ch2 = ch2 \ 2
Next
End If
Res = Res & Chr(ch1 Or ch2)
AndNum = AndNum \ 2
cnt = cnt + 1
If AndNum = 0 Then
AndNum = &H7F
cnt = 1
Res = Res & ChrW(AscW(Mid(S, L, 1)) \ 2)
'previously used chr and asc
End If
'PrevChar = Asc(Mid(S, L, 1))
Next
MakeOctetTo7Bit = Res
End Function
Public Function MakeSubmitPDU(ByVal PhoneNo As String, ByVal MessageStr As String) As String
MakeSubmitPDU = ""
On Error GoTo er
If (Len(PhoneNo) < 3) Or (Len(PhoneNo) > 20) Or (MessageStr = "") Then Exit Function
' should check for phone number to be valid digits is assumed
Dim SMSC_Info_Len As String
SMSC_Info_Len = "00"
Dim FirstOctet As String
FirstOctet = "11"
Dim TP_MessageRef As String
TP_MessageRef = "00"
Dim NumberLen As String
NumberLen = HexChar(Len(PhoneNo))
Dim NumberType As String
Dim SemiOctetNumber As String
NumberType = "81" 'local number81
SemiOctetNumber = GetSemiOctet(PhoneNo)
If Left(PhoneNo, 1) = "+" Then
NumberType = "91" 'international number
SemiOctetNumber = GetSemiOctet(Right(PhoneNo, Len(PhoneNo) - 1))
NumberLen = HexChar(Len(PhoneNo) - 1)
ElseIf Left(PhoneNo, 2) = "00" Then
NumberType = "91"
SemiOctetNumber = GetSemiOctet(Right(PhoneNo, Len(PhoneNo) - 2))
NumberLen = HexChar(Len(PhoneNo) - 2)
End If
Dim Protocol_id As String
Protocol_id = "00"
Dim DCS As String 'data coding scheme
DCS = ""
If Is7Bit(MessageStr) Then DCS = "00" '7 bit
If DCS = "" And IsUTF8(MessageStr) Then DCS = "04" '8 bit
If DCS = "" Then DCS = "08" '16 bit
Dim Validity As String
Validity = "AA" '4 days
Dim UDS As String 'user data size
If DCS <> "08" Then
UDS = HexChar(Len(MessageStr))
Else
UDS = HexChar(Len(MessageStr) * 2)
End If
Dim L As Integer
Dim UserData As String
UserData = ""
Select Case DCS
Case "00"
If Len(MessageStr) > 160 Then Exit Function
UserData = Make7Bit2Octet(MessageStr)
Case "04"
If Len(MessageStr) > 140 Then Exit Function
For L = 1 To Len(MessageStr)
UserData = UserData & HexChar(Asc(Mid(MessageStr, L, 1)))
Next
Case "08"
If Len(MessageStr) > 70 Then Exit Function
For L = 1 To Len(MessageStr)
UserData = UserData & Char2Hex(Mid(MessageStr, L, 1))
Next
End Select
MakeSubmitPDU = SMSC_Info_Len & FirstOctet & TP_MessageRef & _
NumberLen & NumberType & SemiOctetNumber & _
Protocol_id & DCS & Validity & _
UDS & UserData
Exit Function
er:
MakeSubmitPDU = ""
End Function
Public Function HexByteVal(ByVal HC As String) As Long
' was integer return type but causes overflow when convertion in charw long type
HexByteVal = 0
If Len(HC) <> 2 Then Exit Function
HexByteVal = HexDigitVal(Left(HC, 1)) * &H10 + HexDigitVal(Right(HC, 1))
End Function
Public Function GetHexByte(ByVal Str As String, ByVal Pos As Integer) As String
GetHexByte = ""
If Pos < 1 Or Pos >= Len(Str) Then Exit Function
GetHexByte = Mid(Str, Pos, 2)
End Function
Public Function DecodeDeliverPDU(ByVal PDU As String, ByVal HasSMSC As Boolean, ByRef Sender As String, ByRef dtTimeStamp As String) As String
Sender = ""
DecodeDeliverPDU = ""
dtTimeStamp = ""
On Error GoTo er
If PDU = "" Then Exit Function
If Not (IsHexDigit(PDU)) Then Exit Function
Dim Cur As Integer
Dim v As Integer
Dim S As String
Dim PDUlen As Integer
PDUlen = Len(PDU)
Cur = 1
If HasSMSC Then
S = GetHexByte(PDU, Cur)
v = HexByteVal(S)
Cur = Cur + 2 + v * 2 ' ignore smsc info
End If
Cur = Cur + 2 'ignore first octet
If Cur > PDUlen Then Exit Function
Dim NumLen As Integer
S = GetHexByte(PDU, Cur)
NumLen = HexByteVal(S)
Cur = Cur + 2 ' skip numlen to go to num type
If Cur > PDUlen Then Exit Function
S = GetHexByte(PDU, Cur)
If S = "91" Then Sender = "+"
Cur = Cur + 2 'skip num type to go to number
If Cur > PDUlen Then Exit Function
v = NumLen
If ((NumLen Mod 2) <> 0) Then v = NumLen + 1
S = GetSemiOctet(Mid(PDU, Cur, v))
Sender = Sender & Left(S, NumLen)
If UCase(Right(Sender, 1)) = "F" Then Sender = Left(Sender, Len(Sender) - 1)
Cur = Cur + v 'skip number
Cur = Cur + 2 'skip protocol id
If Cur > PDUlen Then Exit Function
Dim DCS As String
DCS = GetHexByte(PDU, Cur)
Cur = Cur + 2 'skip dcs
Cur = Cur + 14 'skip semi-octet time stamp
If Cur > PDUlen Then Exit Function
dtTimeStamp = GetSemiOctet(Mid(PDU, Cur - 14, 14))
Dim UDL As Integer 'user data length
S = GetHexByte(PDU, Cur)
UDL = HexByteVal(S)
Cur = Cur + 2 'skip udl & goto data
If Cur > PDUlen Then Exit Function
Dim L As Integer
Dim Lp As Integer
Dim UserData As String
Dim UserStr As String
UserData = ""
UserData = Right(PDU, Len(PDU) - Cur + 1)
UserStr = ""
'If DCS <> "04" And DCS <> "08" Then
If DCS = "00" Then
'coding scheme 7bit
UserStr = MakeOctetTo7Bit(UserData)
ElseIf DCS = "04" Then
'8 bit
For Lp = 1 To Len(UserData) Step 2
S = GetHexByte(UserData, Lp)
UserStr = UserStr & Chr(HexByteVal(S))
Next
ElseIf DCS = "08" Then
'16 bit
Dim s1 As String
Dim s2 As String
For Lp = 1 To Len(UserData) Step 4
s1 = GetHexByte(UserData, Lp)
s2 = GetHexByte(UserData, Lp + 2)
UserStr = UserStr & ChrW(HexByteVal(s1) * &H100 + HexByteVal(s2))
Next
End If
DecodeDeliverPDU = UserStr
Exit Function
er:
DecodeDeliverPDU = ""
End Function
Public Function SubmitPDU2Str(ByVal PDU As String, ByRef Receiver As String) As String
'i'm not sure this will work as i'm not properly checking first octet for validity byte presence
Receiver = ""
SubmitPDU2Str = ""
On Error GoTo er
If PDU = "" Then Exit Function
If Not (IsHexDigit(PDU)) Then Exit Function
Dim Cur As Integer
Dim v As Integer
Dim S As String
Dim PDUlen As Integer
PDUlen = Len(PDU)
Cur = 1
S = GetHexByte(PDU, Cur)
v = HexByteVal(S)
Cur = Cur + 2 + v * 2 ' ignore smsc info
If Cur > PDUlen Then Exit Function
'if first octet=01 then no validity period
Dim FirstOctet As Integer
S = GetHexByte(PDU, Cur)
FirstOctet = HexByteVal(S)
Cur = Cur + 2 'skip first octet
Cur = Cur + 2 'skip tp message ref
If Cur > PDUlen Then Exit Function
Dim NumLen As Integer
S = GetHexByte(PDU, Cur)
NumLen = HexByteVal(S)
Cur = Cur + 2 ' skip numlen to go to num type
If Cur > PDUlen Then Exit Function
S = GetHexByte(PDU, Cur)
If S = "91" Then Receiver = "+"
Cur = Cur + 2 'skip num type to go to number
If Cur > PDUlen Then Exit Function
v = NumLen
If ((NumLen Mod 2) <> 0) Then v = NumLen + 1
S = GetSemiOctet(Mid(PDU, Cur, v))
Receiver = Receiver & Left(S, NumLen)
If UCase(Right(Receiver, 1)) = "F" Then Receiver = Left(Receiver, Len(Receiver) - 1)
Cur = Cur + v 'skip number
Cur = Cur + 2 'skip protocol id
If Cur > PDUlen Then Exit Function
Dim DCS As String
DCS = GetHexByte(PDU, Cur)
Cur = Cur + 2 'skip dcs
If (FirstOctet And &H18) = &H10 Then
Cur = Cur + 2 'skip validity
ElseIf (FirstOctet And &H18) <> 0 Then
Cur = Cur + 14 '7 octet validity
End If
If Cur > PDUlen Then Exit Function
Dim UDL As Integer 'user data length
S = GetHexByte(PDU, Cur)
UDL = HexByteVal(S)
Cur = Cur + 2 'skip udl & goto data
If Cur > PDUlen Then Exit Function
Dim L As Integer
Dim Lp As Integer
Dim UserData As String
Dim UserStr As String
UserData = ""
UserData = Right(PDU, Len(PDU) - Cur + 1)
UserStr = ""
'If DCS <> "04" And DCS <> "08" Then
If DCS = "00" Then
'coding scheme 7bit
UserStr = MakeOctetTo7Bit(UserData)
ElseIf DCS = "04" Then
'8 bit
For Lp = 1 To Len(UserData) Step 2
S = GetHexByte(UserData, Lp)
UserStr = UserStr & Chr(HexByteVal(S))
Next
ElseIf DCS = "08" Then
'16 bit
Dim s1 As String
Dim s2 As String
For Lp = 1 To Len(UserData) Step 4
s1 = GetHexByte(UserData, Lp)
s2 = GetHexByte(UserData, Lp + 2)
UserStr = UserStr & ChrW(HexByteVal(s1) * &H100 + HexByteVal(s2))
Next
End If
SubmitPDU2Str = UserStr
Exit Function
er:
SubmitPDU2Str = ""
End Function
End Class
باید این نکته را متذکر شوم که فقط باید از تابع MakeSubmitPDU استفاده کنید
قوانین ایجاد تاپیک در تالار
پاسخ با نقل قول