Announcement

Collapse
No announcement yet.

How to fill Customlist via Plugin

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • How to fill Customlist via Plugin

    Hi Folks

    I want create an own Contactlist incl. Name, Number and Photo.
    How can i fill a customlist with my vb6 plugin?

    regards
    RR-Skin: BMW OpenBM Skin for E39 [never ending progress :-(]
    RR-Plugin: IBusCommunicatoRR new Updates

  • #2
    harryberlin , i want something like that , you make that ? thanks

    Comment


    • #3
      In my Case with VB6

      to add without Image:
      frm.CLAddItem "Numberstring" & vbCrLf & "Namestring"
      vbCrLf is the seperator for listtext and listdesc

      to add with Image(since RR Version Jul01 2014):
      frm.CLAddItemWithImage "Numberstring" & vbCrLf & "Namestring", "ImageFullpathString"

      before you should check, if a customlist on screen exist:
      If frm.IsShowCL Then ....
      or
      If Not frm.IsShowCL Then Exit Sub

      and clear the customlist before fill a complete new list:
      frm.CLClear

      For other Things check the Documetation Folder these files:
      "Extension Plugin Form properties.txt"
      "dot Net Extension Plugin frm Object.txt"

      I use this to import Names, Numbers, Photos of exported VCard from S3 mini, for my plugin.

      Last edited by harryberlin; 07-08-2014, 06:38 PM.
      RR-Skin: BMW OpenBM Skin for E39 [never ending progress :-(]
      RR-Plugin: IBusCommunicatoRR new Updates

      Comment


      • #4
        Thanks for this share . How do you download from your S3 to your plugin the VCARD ?

        Comment


        • #5
          in contactlist or phonebook there is an option to export all contacts to SD.
          in Phonebook >> Settings >> Import/Export >> to SD Card
          after than you have a vcf file on your SD Card.
          for Filetransfer to PC, i'm using MyPhoneExplorer.
          Last edited by harryberlin; 08-30-2014, 04:28 AM.
          RR-Skin: BMW OpenBM Skin for E39 [never ending progress :-(]
          RR-Plugin: IBusCommunicatoRR new Updates

          Comment


          • #6
            Originally posted by harryberlin View Post
            in contactlist or phonebook there is an option to export all contacts to SD.
            in Phonebook >> Settings >> Import/Export >> to SD Card
            after than you have a vcf file on your SD Card.
            for Filetransfer to PC, i'm using MyPhoneExplorer.
            Ok , thanks

            Comment


            • #7
              This thread is old, but if someone can help me ?
              I try to use CLAddItem into VB.NET 2010.
              This is my code:
              Code:
              SDK.Execute("MENU;MOBILEPHONE_MESSAGEBOX.SKIN||CLCLEAR;ALL||SETVAR;MOBILEPHONE_INFO;Message Info", True)
                                  Dim allLines As String() = IO.File.ReadAllLines(MainPath & "MobilePhone_BlackList.lst", Encoding.Default)
                                  For Each ph In allLines
                                      If File.Exists(BlueSoleil_BS_PBAP_GetImageFromNumber(ph)) Then
                                          frm.CLAddItem(ph & vbCrLf & BlueSoleil_PBAP_GetNameFromNumber(ph))
                                      Else
                                          frm.CLAddItem(ph & vbCrLf & "Unknow")
                                      End If
                                  Next
              With the picture option, i have the same issue:
              Code:
              SDK.Execute("MENU;MOBILEPHONE_MESSAGEBOX.SKIN||CLCLEAR;ALL||SETVAR;MOBILEPHONE_INFO;Message Info", True)
                                  Dim allLines As String() = IO.File.ReadAllLines(MainPath & "MobilePhone_BlackList.lst", Encoding.Default)
                                  For Each ph In allLines
                                      If File.Exists(BlueSoleil_BS_PBAP_GetImageFromNumber(ph)) Then
                                          frm.CLAddItemWithImage(ph & vbCrLf & BlueSoleil_PBAP_GetNameFromNumber(ph), BlueSoleil_BS_PBAP_GetImageFromNumber(ph))
                                      Else
                                          frm.CLAddItemWithImage(ph & vbCrLf & "Unknow") ', MainPath & "Photo\unknow.gif")
                                      End If
                                  Next
              Any help would be appreciated !

              Comment


              • #8
                hi pierro. confuse code, there is missing a lot. where did you get customlist object?
                do you save the picture to hdd?
                where is the errormessage to get help?
                can't read something about your problem. just snipped vb.net code.

                this is my vb6 code:
                usual riderunner function
                Code:
                Public Function ProcessCommand(CMD As String, frm As Object) As Integer
                
                    Select Case LCase(CMD)
                        Case "onscreenchange"
                            If LCase(RRSDK.GetInfo("RRSCREEN")) = "bmw_phone.skin" Then ImportVCardtoRRCL frm
                            ProcessCommand = 2
                            
                    End Select
                    
                End Function
                and my modul of most phone functions.
                Code:
                'This file is part of IBusComminicatoRR.
                
                'IBusComminicatoRR is free software: you can redistribute it and/or modify
                'it under the terms of the GNU General Public License as published by
                'the Free Software Foundation, either version 3 of the License, or
                '(at your option) any later version.
                
                'IBusComminicatoRR is distributed in the hope that it will be useful,
                'but WITHOUT ANY WARRANTY; without even the implied warranty of
                'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                'GNU General Public License for more details.
                
                'You should have received a copy of the GNU General Public License
                'along with IBusComminicatoRR.  If not, see <http://www.gnu.org/licenses/>.
                
                Option Explicit
                
                Dim sVcAdded As String
                Dim PhoneMenu As Boolean
                
                ' for Vcimg convertion ----------------------------------------------------
                Private Const clOneMask = 16515072          '000000 111111 111111 111111
                Private Const clTwoMask = 258048            '111111 000000 111111 111111
                Private Const clThreeMask = 4032            '111111 111111 000000 111111
                Private Const clFourMask = 63               '111111 111111 111111 000000
                
                Private Const clHighMask = 16711680         '11111111 00000000 00000000
                Private Const clMidMask = 65280             '00000000 11111111 00000000
                Private Const clLowMask = 255               '00000000 00000000 11111111
                
                Private Const cl2Exp18 = 262144             '2 to the 18th power
                Private Const cl2Exp12 = 4096               '2 to the 12th
                Private Const cl2Exp6 = 64                  '2 to the 6th
                Private Const cl2Exp8 = 256                 '2 to the 8th
                Private Const cl2Exp16 = 65536              '2 to the 16th
                
                Private Const TransPixel As String = "R0lGODlhAQABAIAAAAAAAP///yH5BAEAAAEALAAAAAABAAEAAAgEAAMEBAA7"
                ' for Vcimg convertion ----------------------------------------------------
                
                ' for utf8 to ansi convertion ----------------------------------------------------
                Private Declare Function WideCharToMultiByte Lib "kernel32.dll" ( _
                                         ByVal CodePage As Long, _
                                         ByVal dwFlags As Long, _
                                         ByVal lpWideCharStr As Long, _
                                         ByVal cchWideChar As Long, _
                                         ByVal lpMultiByteStr As Long, _
                                         ByVal cbMultiByte As Long, _
                                         ByVal lpDefaultChar As Long, _
                                         ByVal lpUsedDefaultChar As Long) As Long
                                        
                Private Declare Function MultiByteToWideChar Lib "kernel32.dll" ( _
                                         ByVal CodePage As Long, _
                                         ByVal dwFlags As Long, _
                                         ByVal lpMultiByteStr As Long, _
                                         ByVal cbMultiByte As Long, _
                                         ByVal lpWideCharStr As Long, _
                                         ByVal cchWideChar As Long) As Long
                                        
                Private Const CP_UTF8 As Long = 65001
                ' for utf8 to ansi convertion ----------------------------------------------------
                
                ' This module provides functionality for the Phone function
                
                Public Sub ImportVCardtoRRCL(ByRef RRfrm As Object)
                
                'check for existing custumlist
                If Not RRfrm.IsShowCL Then Exit Sub
                Debug.Print "Existiert eine CL auf dem Screen?: " & RRfrm.IsShowCL
                Debug.Print "On Start of Import VCard : CLMaxValue: " & RRfrm.clmax & "; CLPosValue: " & RRfrm.CLValue
                
                Dim RRCLPos, i, iVC, iVcCnt As Integer: iVcCnt = 0
                
                If fVc = "" Then fVc = pluginpath & "vcard.vcf"
                Dim sVcIn As String
                
                Dim bVC, bVCNbr, bVcImg As Boolean
                
                RRCLPos = RRfrm.CLValue
                RRfrm.CLClear
                'Debug.Print CBool(Dir(fVc) <> "")
                If Dir(fVc) = "" Then
                    RRfrm.CLAddItemWithImage "", CStr(imgVcConv(TransPixel, -1))
                    RRfrm.CLAddItemWithImage "no VCard loaded", CStr(imgVcConv(TransPixel, -1))
                    RRfrm.CLAddItemWithImage "add Contact", CStr(imgVcConv(TransPixel, -1))
                    RRfrm.CLAddItemWithImage "to create", CStr(imgVcConv(TransPixel, -1))
                    Exit Sub
                End If
                
                
                ' check for image temp dir
                If Dir(pluginpath & "VcImgTmp", vbDirectory) = "" Then MkDir (pluginpath & "VcImgTmp")
                
                
                'for RR Customlist
                Dim RRCLName, RRCLNbr, RRCLImg, RRCLImg_tmp As String
                Dim aRRCLName(), aRRCLNbr() As String: ReDim aRRCLName(0): ReDim aRRCLNbr(0)
                
                Dim aVcName() As String, aVcNbr() As String, aVCImg() As String
                Dim aVcCnt, aVcNbrCnt As Integer: aVcCnt = 0: aVcNbrCnt = 0
                
                iVC = FreeFile()
                
                Open fVc For Input As #iVC
                    
                    Do Until EOF(iVC)
                        Line Input #iVC, sVcIn
                        'Debug.Print sVcIn
                        If UCase(Left(sVcIn, 11)) = "BEGIN:VCARD" Then bVC = True
                        
                        'get name
                        If bVC And UCase(Left(sVcIn, 3)) = "FN:" Then RRCLName = Mid(sVcIn, 4)
                        If bVC And UCase(Left(sVcIn, 43)) = "FN;CHARSET=UTF-8;ENCODING=QUOTED-PRINTABLE:" Then RRCLName = Trim(ConvertFromUTF8(Mid(sVcIn, 44)))
                        
                        ' get number
                        If bVC And UCase(Left(sVcIn, 4)) = "TEL;" Then
                            ReDim Preserve aRRCLName(aVcNbrCnt)
                            ReDim Preserve aRRCLNbr(aVcNbrCnt)
                            aRRCLNbr(aVcNbrCnt) = Mid(sVcIn, (InStrRev(sVcIn, ":", -1, vbTextCompare) + 1))
                            aRRCLName(aVcNbrCnt) = RRCLName & " (" & ULCase(Replace(Mid(sVcIn, 5, InStrRev(sVcIn, ":", -1, vbTextCompare) - 5), "X-", "")) & ")"
                            aVcNbrCnt = aVcNbrCnt + 1
                        End If
                        
                        
                        'get photo string
                        If bVcImg Then RRCLImg_tmp = RRCLImg_tmp & sVcIn
                        If bVC And UCase(Left(sVcIn, 27)) = "PHOTO;ENCODING=BASE64;JPEG:" Then RRCLImg_tmp = Mid(sVcIn, 28): bVcImg = True
                        If bVcImg And sVcIn = "" Then bVcImg = False
                        
                        
                        
                        ' end of vcard and set to array
                        If UCase(Left(sVcIn, 9)) = "END:VCARD" Then
                            bVC = False: bVCNbr = False: bVcImg = False
                            'Debug.Print Len(RRCLImg_tmp)
                            'set img for RR CL
                            If RRCLImg_tmp <> "" Then
                                iVcCnt = iVcCnt + 1
                                RRCLImg = imgVcConv(RRCLImg_tmp, iVcCnt)
                                'MsgBox "wait"
                            Else
                                RRCLImg = imgVcConv(imgVcdef, 0)
                            End If
                            
                            'Debug.Print RRCLImg
                            'add item to RR CL
                            'If RRCLNbr <> "" And
                            If aRRCLNbr(0) = "" Then aRRCLNbr(0) = "no Number"
                            If aRRCLName(0) <> "" And RRCLImg <> "" Then
                                For i = 0 To UBound(aRRCLNbr)
                                    ReDim Preserve aVcName(0 To aVcCnt)
                                    ReDim Preserve aVcNbr(0 To aVcCnt)
                                    ReDim Preserve aVCImg(0 To aVcCnt)
                                    aVcName(aVcCnt) = aRRCLName(i)
                                    aVcNbr(aVcCnt) = aRRCLNbr(i)
                                    aVCImg(aVcCnt) = RRCLImg
                                    aVcCnt = aVcCnt + 1
                                Next i
                            End If
                            'Debug.Print RRCLName & ", " & RRCLNbr '& ", " & RRCLImg
                            aVcNbrCnt = 0: RRCLName = "": ReDim aRRCLNbr(0): aRRCLNbr(0) = "": ReDim aRRCLName(0): aRRCLName(0) = "": RRCLImg = "": RRCLImg_tmp = ""
                
                        End If
                        DoEvents
                    Loop
                Close iVC
                
                
                If IsArrayEmpty(aVcName) And IsArrayEmpty(aVcNbr) And IsArrayEmpty(aVCImg) Then
                    RRfrm.CLAddItemWithImage "", CStr(imgVcConv(TransPixel, -1))
                    RRfrm.CLAddItemWithImage "empty VCard", CStr(imgVcConv(TransPixel, -1))
                    RRfrm.CLAddItemWithImage "found", CStr(imgVcConv(TransPixel, -1))
                    Exit Sub
                End If
                
                If UBound(aVcName) > 0 And UBound(aVcName) = UBound(aVcNbr) And UBound(aVcName) = UBound(aVCImg) Then QuickSortEx aVcName, aVcNbr, aVCImg  'Debug.Print "sort":
                
                'add values to RR Customlist
                'RRfrm.CLClear
                For i = 0 To UBound(aVcName)
                    RRfrm.CLAddItemWithImage aVcNbr(i) & vbLf & aVcName(i), CStr(aVCImg(i))
                    If sVcAdded = aVcNbr(i) Then RRCLPos = i: sVcAdded = ""
                Next i
                
                If RRCLPos > 0 Then RRfrm.CLValue = RRCLPos
                
                RRSDK.Execute "ONCLPOSCHANGE"
                
                End Sub
                
                Public Sub AddContact(sValues As String)
                Dim aValues() As String
                
                aValues = Split(sValues, ";")
                ReDim Preserve aValues(2)
                
                If Replace(aValues(0), " ", "") = "" Or Replace(aValues(1), " ", "") = "" Then RRSDK.ErrScrn "IBusCommunicator Plugin", "VCard Error", "Please set Name and Number": Exit Sub
                If IsEmpty(aValues(2)) Or Replace(aValues(2), " ", "") = "" Then aValues(2) = ""
                AddContacttoVCard aValues(0), aValues(1), aValues(2)
                RRSDK.Execute "SETVAR;IBUSCOMMUNICATORR_VCARD_NAME;||SETVAR;IBUSCOMMUNICATORR_VCARD_NUMBER;||SETVAR;IBUSCOMMUNICATORR_VCARD_IMG;"
                End Sub
                
                Public Sub RemoveContact(sValues As String)
                Dim aValues() As String
                
                aValues = Split(sValues, ";")
                ReDim Preserve aValues(1)
                Debug.Print aValues(0)
                aValues(0) = Mid(aValues(0), 1, InStrRev(aValues(0), " (", -1, vbTextCompare) - 1)
                Debug.Print aValues(0) & " <- trimmed"
                RemoveContactfromVCard aValues(0), IIf(IsEmpty(aValues(1)), "", aValues(1))
                
                End Sub
                
                Private Sub AddContacttoVCard(sVCName As String, sVCNbr, Optional sVCImg As String = "")
                If fVc = "" Then RRSDK.ErrScrn "IBUSCommunicatoRR Plugin", "Vcard is missing", "": Exit Sub
                Dim iVC As Integer: iVC = FreeFile()
                
                
                Open fVc For Append As #iVC
                    Print #iVC, "BEGIN:VCARD"
                    Print #iVC, "VERSION:2.1"
                    'Print #iVC, "N:" & Replace(Text1.Text, " ", ";")
                    Print #iVC, "N;CHARSET=UTF-8;ENCODING=QUOTED-PRINTABLE:" & ConvertToUTF8(sVCName) 'UTF8
                    'Print #iVC, "FN:" & Text1.Text
                    Print #iVC, "FN;CHARSET=UTF-8;ENCODING=QUOTED-PRINTABLE:" & ConvertToUTF8(sVCName) 'UTF8
                    Print #iVC, "TEL;HOME:" & sVCNbr
                    If sVCImg <> "" And ImgToVC(sVCImg) <> "" Then Print #iVC, ImgToVC(sVCImg)
                    Print #iVC, "END:VCARD"
                Close #iVC
                
                sVcAdded = sVCNbr
                
                RRSDK.Execute "IBusCommunicatoRR;BMWPHONE" 'reload vcard to RR CL
                
                End Sub
                
                Private Sub RemoveContactfromVCard(sVCName As String, sVCNbr As String)
                If fVc = "" Then RRSDK.ErrScrn "IBUSCommunicatoRR Plugin", "Vcard is missing", "": Exit Sub
                Debug.Print sVCNbr
                
                Dim i, iVC, sSkipVC, eSkipVC, sSkipVC_tmp, eSkipVC_tmp As Integer: iVC = FreeFile()
                
                Dim bufVC(), sbufVC, delVC  As String
                Dim bVC, bVCNbr, bVCName As Boolean
                Dim RedimCnt As Long: RedimCnt = 0
                Dim iTelRow As Integer: iTelRow = -1
                Dim iTelCnt As Integer: iTelCnt = 0 'if one contact has more as one number
                
                sSkipVC = -1 ' Start Row of VCard to remove
                eSkipVC = -1 ' End Row of VCard to remove
                
                Open fVc For Input As #iVC
                    
                    Do Until EOF(iVC)
                        ReDim Preserve bufVC(RedimCnt)
                        Line Input #iVC, sbufVC
                        bufVC(RedimCnt) = sbufVC
                        
                        RedimCnt = RedimCnt + 1
                        
                        
                        DoEvents
                    Loop
                Close iVC
                'MsgBox UBound(bufVC)
                
                For i = 0 To UBound(bufVC)
                    ' start of VCard
                    If UCase(Left(bufVC(i), 11)) = "BEGIN:VCARD" Then bVC = True: sSkipVC_tmp = i
                    'If bVC And InStr(1, bufVC(i), sVCNbr) > 0 Then sSkipVC = sSkipVC_tmp
                    
                    ' find Name
                    If bVC And Not bVCName And UCase(Left(bufVC(i), 3)) = "FN:" Then
                        If LCase(sVCName) = Trim(LCase(Mid(bufVC(i), 4))) Then sSkipVC = sSkipVC_tmp: bVCName = True
                    End If
                    
                    If bVC And Not bVCName And UCase(Left(bufVC(i), 43)) = "FN;CHARSET=UTF-8;ENCODING=QUOTED-PRINTABLE:" Then
                        If LCase(sVCName) = LCase(ConvertFromUTF8(Mid(bufVC(i), 44))) Then sSkipVC = sSkipVC_tmp: bVCName = True
                    End If
                    
                    ' find number
                    If bVC And UCase(Left(bufVC(i), 3)) = "TEL" Then 'And Not bVCNbr
                        iTelCnt = iTelCnt + 1
                        If sVCNbr = Mid(bufVC(i), (InStrRev(bufVC(i), ":", -1, vbTextCompare) + 1)) And Not bVCNbr Or LCase(sVCNbr) = "no number" Then bVCNbr = True: iTelRow = i
                    End If
                    
                    ' end of VCard
                    If UCase(Left(bufVC(i), 9)) = "END:VCARD" Then
                        If bVCName And sSkipVC <> -1 And eSkipVC = -1 Then eSkipVC = i
                        'Debug.Print i & " Cnt: " & iTelCnt
                        If bVCNbr And iTelCnt > 1 Then sSkipVC = iTelRow: eSkipVC = iTelRow
                        bVC = False: iTelCnt = 0: bVCNbr = False: bVCName = False
                    End If
                Next i
                
                Debug.Print "Number found in Row: " & iTelRow
                
                Debug.Print "VCard Lines Range to skip/delete: " & sSkipVC & " -> " & eSkipVC
                
                
                If sSkipVC = -1 And eSkipVC = -1 Then RRSDK.ErrScrn "IBUSCommunicator Plugin", sVCName & " " & sVCNbr, "VCard to remove not found": Exit Sub
                
                'Exit Sub '<- just for test
                
                Open fVc For Output As #iVC
                    'Print #iVC, Chr$(239) & Chr$(187) & Chr$(191); ' NEU
                    
                    ' write Lines back to VCard
                    For i = 0 To UBound(bufVC)
                        If i < sSkipVC Or i > eSkipVC Then Print #iVC, bufVC(i)
                    Next i
                Close #iVC
                
                If DebugLVL > 0 Then
                    If sSkipVC = eSkipVC Then
                        RRSDK.RRlog "IBusCommunicatoRR: Deleted '" & sVCNbr & "' from Contact '" & sVCName & "'"
                    Else
                        RRSDK.RRlog "IBusCommunicatoRR: Deleted Contact '" & sVCName & "'"
                    End If
                End If
                
                End Sub
                
                
                'Convert String to PNG Imagefile
                Private Function imgVcConv(sJPG As String, ByVal FileNbr As Long) As String
                imgVcConv = ""
                
                Dim iFile As Integer
                Dim savefullpath As String: savefullpath = pluginpath & "VcImgTmp\vcimg" & FileNbr & ".png"
                
                
                'Dim sJPG As String
                
                'clean input string
                sJPG = Replace(sJPG, vbCrLf, "")
                sJPG = Replace(sJPG, " ", "")
                
                'save to file
                iFile = FreeFile()
                Open savefullpath For Binary As #iFile
                
                Put #iFile, , Decode64(sJPG)
                Close #iFile
                        
                'set path of new file as output
                imgVcConv = savefullpath
                End Function
                
                'default Contactpicture as string
                Private Function imgVcdef() As String
                Dim imgVcdef_tmp(19)
                
                imgVcdef_tmp(1) = "iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAAGXRFWHRTb2Z0d2FyZQBBZG9iZSBJbWFnZVJlYWR5ccllPAAAB7RJREFUeNrEV2uMVdUV/vZ53ufMnSfMg0EJtaIwUCiDQqJJYzW1FGpI"
                imgVcdef_tmp(2) = "qyS0Shykj6Q2Jala26RtKMYfNGp/2ZjUxCam5UejaROxhFGLqBRqrLbjCIiQgYFhmPu+55x99qNrH4aRoUohTtKd7Jydc8/a61vfel6mtcb/czmX+/G+Rbnp87PDtenzlv7C0nzWf6jQlF7BgD6m5UTE"
                imgVcdef_tmp(3) = "xb+40G+7qfyT2/ccPn3pHRfLXzGAT1pbl7U+0tPZtOOG67vR3JQCb4SQtVKvlqq3GNl3TNb4g49+qe/+X+098fyV3GddjXKyfLC3PbWjtyOHprSPbCYDz/fICgXHUmjOOujrm5vubMs998itPTfPKgCi"
                imgVcdef_tmp(4) = "MjenkPp1eyGHPFnuejY814atJaAVtGaIWBrpXAadc9tsIcQzJGPPGoBMyt3clEvnU2R5Op2G46QQBQr1chlSakyGDCHnKJfrYJaFlkL+hozv3fqZgvDilfLdtZbFIJTCeDnA+8cmUKnW4KoYqZQHSdmU"
                imgVcdef_tmp(5) = "anIxJ5eCYIwIYbBdrEOEvbMCgDE2UG3E6Fq0BMsHluHs2UlUJkuoVqpEeTu6uzqQzWUR8winxs6w0RNnlOt6GwD+w1kBEMWyOd2cxsCqJcjns2htaYIiNjRtJU0MKAghQdmA9uY8sm2dVnj8VPesuSCK"
                imgVcdef_tmp(6) = "YtbR1aktIjeOOSxFolQEEuXqPACtJKQQkMRCoZDTYRhbswaA2WyUon9uHIcOXIuiX1MEWzCVVFMmSEnWEwNxFCAWIQVoRdqOfVZxMTtZ0DynZZUlKiEPQx0HIdEdkwtoa7KYGDCZIKWAIHbiKIQla6Pc"
                imgVcdef_tmp(7) = "8/s/EwPHKh+jP/be2KmBxV0HZcxvUY7DJKWapjA3DJB+qgWSlIdQ5AIeBiqf8V766FR5wsi+ejL8dGYvNKMHtj7+P1n4cu6Fh7t7r/llLpt37VQatuPBtmxigVzAY1JcB6/XUKqWokqldNtfa+v3Xe6+"
                imgVcdef_tmp(8) = "3z790NWVYlq/mxg/HcU8RBw2IKIGpV0dFBe0A2IgItdwTcpf/cbO/ftmvRfQpWc4D5+oVstx1KgjqJfRqBQRVsqIatXE96Vq2fD9zFW343zrjZf9cOdjay+A+NmubavnFwqtmzKZNFVdBxbFQyw4SqWi"
                imgVcdef_tmp(9) = "DoLGdvpm16zMA5eu+wd3DPT3L3x4+Vce+9qZlx5VjVrZFlQHqEzCsS0EsQ6XbXl+/VNP/XH4nX8eeZFE5BW7IEmpT9nnTh/69n2bf/43ZnlDKweWrl+6crkjtW1nqQe0NaVRyPrUGR2cwwL/uuv6Bub1"
                imgVcdef_tmp(10) = "df+BUrIoZfw47c/RxiftGQwIESXP3+y8J3l+ddPLaGGvbabjoOsXvgCvx4912lq4oBOnz4yhc9W9OH7gz0jpSXBkUbe78cU777aOHDmMGxdf6/5p9xIHsvIj8NHvKxm8YOKiqG8Z+svvb0/u3/Stn14C"
                imgVcdef_tmp(11) = "IP44V+/e+OP+rNaDym/bAqfHD5Bl4AyuzeH7DpXZAs72XI/+DUvQTG2ZMQtF0UBEbJnfqBRQWY5ZrJocOIsczar3sPj413Nyz5PA7T8xOkzMzHCBSSOz79rw4EYaJl4XaP6uUH5KihpzUITHJqnuU5SX"
                imgVcdef_tmp(12) = "Sujs7MSaNauRVgJv3rsRB783iKzrYvXq1clvk5PnvzUyRhaqYUnkMgH3t9214QdPnNfHZzLAeQPFiSNpiqin/UwhHUWBbfLbdVxKLyQFx6JA++CDo5g/fx5GRkYwdOgQOgotUKkUXnnrTWQ6Wmkk68Pw"
                imgVcdef_tmp(13) = "yIdUI0bBKUClMhOTsTg2VdNT2vnO2nVbi8TaL2YAiAlAGDUeyGRbvWq1SsoFzAAiXZr5HHIndT7P8/DavneQy/nY/8ZBDP9jDBvPnkNAIHcfGkMYv4ibb1qJAweGqSRHZBSHKbTClGeyWCkN22YeJe02"
                imgVcdef_tmp(14) = "UrndZMlFDNRNFVtHHzl1KjKS0Jv8pndwKcLNTbFwcPgox96hN/Duvycgwgg5AumRicVKA38nEI3G6zh2YpyeERklkhQ1xsTUKc38YNsWS3vM5bx2G6ndPYMBCozFhNriUZx0OJIlIHYCgvQg4hqNehXj"
                imgVcdef_tmp(15) = "4xPwPRfzVUjhyZClWaAprGA8sLFnaDxRpIzpNKgqwwB1ymRY0caV1MqplfE46p8B4OTJkZzr+ZlqrcpCLhNh43NFPhSk3bJM1xNJ9/NpIpY0kLSL6nTmtDWK+IilEmsjkqcRDqZKKsUS6pUBQ6zGzJyF"
                imgVcdef_tmp(16) = "BRnOmxkDJi3MIAlTJIxyN1Fu+j1jKtlm8pHJGOYQEIG2sDwNoL1G9cBvpclJkb9FYimzDGAr2aBc0rSV5JCWZCrm3ow0fPftV+pEC0VNTMgp4gkpYUUSwgRKK55UL8NCYAYSCqq5UX0agDmbd+Y38435"
                imgVcdef_tmp(17) = "1sgYWXOHucvcae6m95oLzv+rF4RhfRdNOt+0qdFL5TmUNZbnWsxcZttgRAhzCLKiFlStc3TJaFq2i6LevCOvGXclIcDMpEguYBbxKExcUFTqQNSD2m7Og2dnDCQ3rbkDb+1/OUvH7pa2rhWO6/Y4jjff"
                imgVcdef_tmp(18) = "cb1r6Z1HoDpIb5ZMYfRujpFdqNX0Px/iSn9oNCkVUh8oGe30nCAoVXLlpJJiPAob7/EoOFKrFkdI5Bzp5jMAmEUgjFtco/SipzO17al94Xzp0lMdUEw9L5zjqW0oM9TLBZ9foY++fxD/EWAArbd0UmSq"
                imgVcdef_tmp(19) = "sJUAAAAASUVORK5CYII="
                
                imgVcdef = Join(imgVcdef_tmp, "")
                
                End Function
                
                Private Function ImgToVC(imagefullpath As String) As String
                    Dim iFile As Integer
                    Dim strAttachment As String
                    Dim imgFile As String
                    Dim aVCImg() As String
                    Dim sVCImg As String
                    Dim sVCImg_tmp As String
                    
                    If imagefullpath = "" Then ImgToVC = "": Exit Function
                    
                    imgFile = imagefullpath '"C:\cd.png"
                    
                    iFile = FreeFile()
                    Open imgFile For Binary Access Read Lock Write As #iFile
                    strAttachment = String$(LOF(iFile), Chr$(0))
                    Get #iFile, , strAttachment
                    Close #iFile
                        
                    sVCImg_tmp = "PHOTO;ENCODING=BASE64;JPEG:" & Replace(Encode64(strAttachment), vbCrLf, "") 'add prefix and replace textwrap
                    
                    'Debug.Print Len(sVCImg_tmp)
                    If Len(sVCImg_tmp) > 100000 Then RRSDK.ErrScrn "IBusCommunicatoRR Plugin", "Picturesize to big", "added Contact without Photo": GoTo ende 'sVCImg_tmp = imgVcdef
                    
                    Do While sVCImg_tmp <> " "
                    sVCImg = sVCImg & Mid(sVCImg_tmp, 1, 74) & vbCrLf
                    sVCImg_tmp = " " & Mid(sVCImg_tmp, 75)
                    DoEvents
                    Loop
                    
                    
                    Debug.Print "Splitting done"
                    
                    ImgToVC = sVCImg
                    
                    Exit Function
                ende:
                ImgToVC = ""
                End Function
                
                
                ' for Vcimg convertion --------------------------------------------------------------------------------------------
                ' for Vcimg convertion --------------------------------------------------------------------------------------------
                Private Function Encode64(sString As String) As String
                
                    Dim bTrans(63) As Byte, lPowers8(255) As Long, lPowers16(255) As Long, bOut() As Byte, bIn() As Byte
                    Dim lChar As Long, lTrip As Long, iPad As Integer, lLen As Long, lTemp As Long, lPos As Long, lOutSize As Long
                
                    For lTemp = 0 To 63                                 'Fill the translation table.
                        Select Case lTemp
                            Case 0 To 25
                                bTrans(lTemp) = 65 + lTemp              'A - Z
                            Case 26 To 51
                                bTrans(lTemp) = 71 + lTemp              'a - z
                            Case 52 To 61
                                bTrans(lTemp) = lTemp - 4               '1 - 0
                            Case 62
                                bTrans(lTemp) = 43                      'Chr(43) = "+"
                            Case 63
                                bTrans(lTemp) = 47                      'Chr(47) = "/"
                        End Select
                    Next lTemp
                
                    For lTemp = 0 To 255                                'Fill the 2^8 and 2^16 lookup tables.
                        lPowers8(lTemp) = lTemp * cl2Exp8
                        lPowers16(lTemp) = lTemp * cl2Exp16
                    Next lTemp
                
                    iPad = Len(sString) Mod 3                           'See if the length is divisible by 3
                    If iPad Then                                        'If not, figure out the end pad and resize the input.
                        iPad = 3 - iPad
                        sString = sString & String(iPad, Chr(0))
                    End If
                
                    bIn = StrConv(sString, vbFromUnicode)               'Load the input string.
                    lLen = ((UBound(bIn) + 1) \ 3) * 4                  'Length of resulting string.
                    lTemp = lLen \ 72                                   'Added space for vbCrLfs.
                    lOutSize = ((lTemp * 2) + lLen) - 1                 'Calculate the size of the output buffer.
                    ReDim bOut(lOutSize)                                'Make the output buffer.
                
                    lLen = 0                                            'Reusing this one, so reset it.
                
                    For lChar = LBound(bIn) To UBound(bIn) Step 3
                        lTrip = lPowers16(bIn(lChar)) + lPowers8(bIn(lChar + 1)) + bIn(lChar + 2)    'Combine the 3 bytes
                        lTemp = lTrip And clOneMask                     'Mask for the first 6 bits
                        bOut(lPos) = bTrans(lTemp \ cl2Exp18)           'Shift it down to the low 6 bits and get the value
                        lTemp = lTrip And clTwoMask                     'Mask for the second set.
                        bOut(lPos + 1) = bTrans(lTemp \ cl2Exp12)       'Shift it down and translate.
                        lTemp = lTrip And clThreeMask                   'Mask for the third set.
                        bOut(lPos + 2) = bTrans(lTemp \ cl2Exp6)        'Shift it down and translate.
                        bOut(lPos + 3) = bTrans(lTrip And clFourMask)   'Mask for the low set.
                        If lLen = 68 Then                               'Ready for a newline
                            bOut(lPos + 4) = 13                         'Chr(13) = vbCr
                            bOut(lPos + 5) = 10                         'Chr(10) = vbLf
                            lLen = 0                                    'Reset the counter
                            lPos = lPos + 6
                        Else
                            lLen = lLen + 4
                            lPos = lPos + 4
                        End If
                    Next lChar
                
                    If bOut(lOutSize) = 10 Then lOutSize = lOutSize - 2 'Shift the padding chars down if it ends with CrLf.
                
                    If iPad = 1 Then                                    'Add the padding chars if any.
                        bOut(lOutSize) = 61                             'Chr(61) = "="
                    ElseIf iPad = 2 Then
                        bOut(lOutSize) = 61
                        bOut(lOutSize - 1) = 61
                    End If
                
                    Encode64 = StrConv(bOut, vbUnicode)                 'Convert back to a string and return it.
                
                End Function
                
                Private Function Decode64(sString As String) As String
                
                    Dim bOut() As Byte, bIn() As Byte, bTrans(255) As Byte, lPowers6(63) As Long, lPowers12(63) As Long
                    Dim lPowers18(63) As Long, lQuad As Long, iPad As Integer, lChar As Long, lPos As Long, sOut As String
                    Dim lTemp As Long
                
                    sString = Replace(sString, vbCr, vbNullString)      'Get rid of the vbCrLfs.  These could be in...
                    sString = Replace(sString, vbLf, vbNullString)      'either order.
                
                    lTemp = Len(sString) Mod 4                          'Test for valid input.
                    If lTemp Then
                        Call Err.Raise(vbObjectError, "MyDecode", "Input string is not valid Base64.")
                    End If
                    
                    If InStrRev(sString, "==") Then                     'InStrRev is faster when you know it's at the end.
                        iPad = 2                                        'Note:  These translate to 0, so you can leave them...
                    ElseIf InStrRev(sString, "=") Then                  'in the string and just resize the output.
                        iPad = 1
                    End If
                    
                    For lTemp = 0 To 255                                'Fill the translation table.
                        Select Case lTemp
                            Case 65 To 90
                                bTrans(lTemp) = lTemp - 65              'A - Z
                            Case 97 To 122
                                bTrans(lTemp) = lTemp - 71              'a - z
                            Case 48 To 57
                                bTrans(lTemp) = lTemp + 4               '1 - 0
                            Case 43
                                bTrans(lTemp) = 62                      'Chr(43) = "+"
                            Case 47
                                bTrans(lTemp) = 63                      'Chr(47) = "/"
                        End Select
                    Next lTemp
                
                    For lTemp = 0 To 63                                 'Fill the 2^6, 2^12, and 2^18 lookup tables.
                        lPowers6(lTemp) = lTemp * cl2Exp6
                        lPowers12(lTemp) = lTemp * cl2Exp12
                        lPowers18(lTemp) = lTemp * cl2Exp18
                    Next lTemp
                
                    bIn = StrConv(sString, vbFromUnicode)               'Load the input byte array.
                    ReDim bOut((((UBound(bIn) + 1) \ 4) * 3) - 1)       'Prepare the output buffer.
                    
                    For lChar = 0 To UBound(bIn) Step 4
                        lQuad = lPowers18(bTrans(bIn(lChar))) + lPowers12(bTrans(bIn(lChar + 1))) + _
                                lPowers6(bTrans(bIn(lChar + 2))) + bTrans(bIn(lChar + 3))           'Rebuild the bits.
                        lTemp = lQuad And clHighMask                    'Mask for the first byte
                        bOut(lPos) = lTemp \ cl2Exp16                   'Shift it down
                        lTemp = lQuad And clMidMask                     'Mask for the second byte
                        bOut(lPos + 1) = lTemp \ cl2Exp8                'Shift it down
                        bOut(lPos + 2) = lQuad And clLowMask            'Mask for the third byte
                        lPos = lPos + 3
                    Next lChar
                
                    sOut = StrConv(bOut, vbUnicode)                     'Convert back to a string.
                    If iPad Then sOut = Left$(sOut, Len(sOut) - iPad)   'Chop off any extra bytes.
                    Decode64 = sOut
                
                End Function
                
                Private Function ConvertToUTF8(ByVal Source As String) As String
                    Dim i As Integer
                    Dim Length As Long
                    Dim Pointer As Long
                    Dim Size As Long
                    Dim Buffer() As Byte
                    Dim Buffer_tmp() As String
                    
                    Length = Len(Source)
                    Pointer = StrPtr(Source)
                    Size = WideCharToMultiByte(CP_UTF8, 0, Pointer, Length, 0, 0, 0, 0)
                    ReDim Buffer(0 To Size - 1)
                    
                    WideCharToMultiByte CP_UTF8, 0, Pointer, Length, VarPtr(Buffer(0)), _
                        Size, 0, 0
                    
                    ReDim Buffer_tmp(UBound(Buffer))
                    
                    For i = 0 To UBound(Buffer)
                        Buffer_tmp(i) = Hex(Buffer(i))
                    Next i
                        
                    ConvertToUTF8 = "=" & Join(Buffer_tmp, "=")
                    
                End Function
                
                Private Function ConvertFromUTF8(ByVal VCardInput As String) As String
                    
                    'prepare input
                    Dim Source() As Byte
                    Dim Source_tmp() As String
                    Dim i As Integer
                    
                    If Left(VCardInput, 1) = "=" Then VCardInput = Mid(VCardInput, 2)
                    
                    Source_tmp() = Split(VCardInput, "=")
                    ReDim Source(UBound(Source_tmp))
                    For i = 0 To UBound(Source_tmp)
                        Source(i) = Val("&h" & Source_tmp(i))
                    Next
                
                    
                    ' convert
                    
                    Dim Size As Long
                    Dim Pointer As Long
                    Dim Length As Long
                    Dim Buffer As String
                    
                    Size = UBound(Source) - LBound(Source) + 1
                    Pointer = VarPtr(Source(LBound(Source)))
                    Length = MultiByteToWideChar(CP_UTF8, 0, Pointer, Size, 0, 0)
                    Buffer = Space$(Length)
                    MultiByteToWideChar CP_UTF8, 0, Pointer, Size, StrPtr(Buffer), Length
                    ConvertFromUTF8 = Buffer
                    
                End Function
                
                Private Sub QuickSortEx(vMst As Variant, _
                    vSlv1 As Variant, _
                    vSlv2 As Variant, _
                    Optional ByVal lngStart As Variant, _
                    Optional ByVal lngEnd As Variant)
                
                    'vMst is the Master Array
                    'vSlv1 is the 1st Slave Array sort by same pos like vMst
                    'vSlv2 is the 2nd Slave Array sort by same pos like vMst
                
                 
                     ' Wird die Bereichsgrenze nicht angegeben,
                     ' so wird das gesamte Array sortiert
                     If IsMissing(lngStart) Then lngStart = LBound(vMst)
                     If IsMissing(lngEnd) Then lngEnd = UBound(vMst)
                    
                     Dim i As Long
                     Dim j As Long
                     Dim h1 As Variant
                     Dim h2 As Variant
                     Dim h3 As Variant
                     Dim X As Variant
                    
                     i = lngStart: j = lngEnd
                     X = vMst((lngStart + lngEnd) / 2)
                    
                     ' Array aufteilen
                     Do
                    
                       While (LCase(vMst(i)) < LCase(X)): i = i + 1: Wend
                       While (LCase(vMst(j)) > LCase(X)): j = j - 1: Wend
                    
                       If (i <= j) Then
                         ' Wertepaare miteinander tauschen
                         h1 = vMst(i): h2 = vSlv1(i): h3 = vSlv2(i)
                         vMst(i) = vMst(j): vSlv1(i) = vSlv1(j): vSlv2(i) = vSlv2(j)
                         vMst(j) = h1: vSlv1(j) = h2: vSlv2(j) = h3
                         i = i + 1: j = j - 1
                       End If
                     Loop Until (i > j)
                    
                     ' Rekursion (Funktion ruft sich selbst auf)
                     If (lngStart < j) Then QuickSortEx vMst, vSlv1, vSlv2, lngStart, j
                     If (i < lngEnd) Then QuickSortEx vMst, vSlv1, vSlv2, i, lngEnd
                End Sub
                
                Private Function ULCase(inputStr As String) As String
                    ULCase = UCase(Left(inputStr, 1)) & LCase(Mid(inputStr, 2))
                End Function
                Last edited by harryberlin; 03-28-2016, 10:21 AM.
                RR-Skin: BMW OpenBM Skin for E39 [never ending progress :-(]
                RR-Plugin: IBusCommunicatoRR new Updates

                Comment


                • #9
                  Ok,
                  Thanks for your code !

                  I try that code:
                  Code:
                  Try
                                      SDK.Execute("MENU;MOBILEPHONE_MESSAGEBOX.SKIN||CLCLEAR;ALL||SETVAR;MOBILEPHONE_INFO;Message Info", True)
                                      Dim allLines As String() = IO.File.ReadAllLines(MainPath & "MobilePhone_BlackList.lst", Encoding.Default)
                                      For ph As Integer = 0 To allLines.Length - 1
                                          If File.Exists(BlueSoleil_BS_PBAP_GetImageFromNumber(allLines(ph))) Then
                                                 ImportVCardtoRRCL(frm, allLines(ph), BlueSoleil_BS_PBAP_GetImageFromNumber(allLines(ph)))
                                          Else
                                              ImportVCardtoRRCL(frm, allLines(ph), MainPath & "Photo\unknow.gif")
                                          End If
                                      Next
                                  Catch ex As Exception
                                      MessageBox.Show(ex.Message)
                                  End Try
                                  ProcessCommand = 2
                  and:
                  Code:
                      Public Sub ImportVCardtoRRCL(ByRef RRfrm As Object, text As String, picture As String)
                  
                          'check for existing custumlist
                          If Not RRfrm.IsShowCL Then Exit Sub
                  
                          Dim RRCLPos As Integer
                  
                          RRCLPos = RRfrm.CLValue
                          RRfrm.CLClear()
                  
                          RRfrm.CLAddItemWithImage(text, picture)
                      End Sub
                  But my list is empty

                  Comment


                  • #10
                    try this

                    Code:
                    Public Sub ImportVCardtoRRCL(ByRef RRfrm As Object, text As String, picture As String)
                    
                    'check for existing custumlist
                    If Not RRfrm.IsShowCL Then Exit Sub
                    
                    Dim RRCLPos As Integer
                    Dim text1, text2 as String
                    text1 = text & "-1"
                    text2 = text & "-2"
                    
                    'Backup current CLPos
                    RRCLPos = RRfrm.CLValue
                    
                    'Clear CL
                    'RRfrm.CLClear() 'always clears the list skip if you use as subfunction
                    
                    RRfrm.CLAddItemWithImage text1 & vbCrLf & text2, picture
                    
                    'restore current CLPos
                    If RRCLPos > 0 then RRfrm.CLValue = RRCLPos
                    End Sub
                    Last edited by harryberlin; 03-28-2016, 11:44 AM.
                    RR-Skin: BMW OpenBM Skin for E39 [never ending progress :-(]
                    RR-Plugin: IBusCommunicatoRR new Updates

                    Comment


                    • #11
                      That i understand is that RRfrm.IsShowCL return nothing !

                      Ok,
                      I have found where is my problem !
                      RR code and VB code in same command is always a problem !
                      So, if i do that, it's ok:
                      Code:
                                  Case "mobilephone_deleteonecontactinblacklist"
                                      Try
                                          SDK.Execute("MENU;MOBILEPHONE_MESSAGEBOX.SKIN||CLCLEAR;ALL||SETVAR;MOBILEPHONE_INFO;Message Info||WAIT;0.5||TOTO")
                                      Catch ex As Exception
                                          MessageBox.Show(ex.Message)
                                      End Try
                                      ProcessCommand = 2
                                  Case "toto"
                                      Try
                                          Dim allLines As String() = IO.File.ReadAllLines(MainPath & "MobilePhone_BlackList.lst", Encoding.Default)
                                          For ph As Integer = 0 To allLines.Length - 1
                                              If File.Exists(BlueSoleil_BS_PBAP_GetImageFromNumber(allLines(ph))) Then
                                                  ImportVCardtoRRCL(frm, allLines(ph), BlueSoleil_BS_PBAP_GetImageFromNumber(allLines(ph)))
                                              Else
                                                  ImportVCardtoRRCL(frm, allLines(ph), MainPath & "Photo\unknow.gif")
                                              End If
                                          Next
                                      Catch ex As Exception
                                          MessageBox.Show(ex.Message)
                                      End Try
                                      ProcessCommand = 2
                      But the code see only one line into my list and i have two lines !!!

                      Comment


                      • #12

                        don't clear the list in subfunction. use it before adding items in your function.
                        Code:
                         'Clear CL 'RRfrm.CLClear() 'always clears the list skip if you use as subfunction 
                        the same with backup the CL position.
                        RR-Skin: BMW OpenBM Skin for E39 [never ending progress :-(]
                        RR-Plugin: IBusCommunicatoRR new Updates

                        Comment


                        • #13
                          Ok, thanks for your help !
                          my old code run now ! The issue was that RR load the screen with the list to late , so the code did not found this list !
                          So, i load the screen, wait 0.5 second and run my code !

                          Code:
                                              Dim allLines As String() = IO.File.ReadAllLines(MainPath & "MobilePhone_BlackList.lst", Encoding.Default)
                                              For ph As Integer = 0 To allLines.Length - 1
                                                  If File.Exists(BlueSoleil_BS_PBAP_GetImageFromNumber(allLines(ph))) Then
                                                      frm.CLAddItemWithImage(allLines(ph) & vbCrLf & allLines(ph) & " --> " & BlueSoleil_PBAP_GetNameFromNumber(allLines(ph)), BlueSoleil_BS_PBAP_GetImageFromNumber(allLines(ph)))
                                                  Else
                                                      frm.CLAddItemWithImage(allLines(ph) & vbCrLf & allLines(ph) & " --> Unknow", MainPath & "Photo\unknow.gif")
                                                  End If
                                              Next

                          Comment

                          Working...
                          X