forok658.frm

为将文本转成UTF-8格式的VCF手机通讯录程序.

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1 
   Caption         =   "OKWAP OK676通讯录处理程序"
   ClientHeight    =   6660
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   9840
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   6660
   ScaleWidth      =   9840
   StartUpPosition =   3  '窗口缺省
   Begin VB.TextBox Text3 
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   5055
      Left            =   2640
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   5
      Top             =   1560
      Width           =   7095
   End
   Begin VB.TextBox Text2 
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Left            =   2640
      TabIndex        =   4
      Top             =   840
      Width           =   7095
   End
   Begin VB.TextBox Text1 
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Left            =   2640
      TabIndex        =   2
      Top             =   120
      Width           =   7095
   End
   Begin VB.CommandButton Command1 
      Caption         =   "开 始 转 换"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   15
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   120
      TabIndex        =   0
      Top             =   1560
      Width           =   2415
   End
   Begin MSComDlg.CommonDialog ComDlg 
      Left            =   3960
      Top             =   1680
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Label Label3 
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   4455
      Left            =   0
      TabIndex        =   6
      Top             =   2160
      Width           =   2535
   End
   Begin VB.Label Label2 
      Caption         =   "手机目标文件夹"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   15
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   120
      TabIndex        =   3
      Top             =   960
      Width           =   2535
   End
   Begin VB.Label Label1 
      Caption         =   "通讯录文本文件"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   15
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   120
      TabIndex        =   1
      Top             =   240
      Width           =   2655
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False


Option Explicit
    
  Private Type BrowseInfo
          lngHwnd                 As Long
          pIDLRoot               As Long
          pszDisplayName   As Long
          lpszTitle             As Long
          ulFlags                 As Long
          lpfnCallback       As Long
          lParam                   As Long
          iImage                   As Long
  End Type
    
  Private Const BIF_RETURNONLYFSDIRS = 1
  Private Const MAX_PATH = 260
    
  Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
          (ByVal hMem As Long)
    
  Private Declare Function lstrcat Lib "Kernel32" _
        Alias "lstrcatA" (ByVal lpString1 As String, _
        ByVal lpString2 As String) As Long
          
  Private Declare Function SHBrowseForFolder Lib "shell32" _
        (lpbi As BrowseInfo) As Long
          
  Private Declare Function SHGetPathFromIDList Lib "shell32" _
        (ByVal pidList As Long, ByVal lpBuffer As String) As Long
    
  Public Function BrowseForFolder(ByVal lngHwnd As Long, ByVal strPrompt As String) As String
    
          On Error GoTo ehBrowseForFolder         'Trap   for   errors
    
          Dim intNull     As Integer
          Dim lngIDList     As Long, lngResult       As Long
          Dim strPath     As String
          Dim udtBI     As BrowseInfo
    
          'Set   API   properties   (housed   in   a   UDT)
          With udtBI
                  .lngHwnd = lngHwnd
                  .lpszTitle = lstrcat(strPrompt, "")
                  .ulFlags = BIF_RETURNONLYFSDIRS
          End With
    
          'Display   the   browse   folder...
          lngIDList = SHBrowseForFolder(udtBI)
    
          If lngIDList <> 0 Then
                  'Create   string   of   nulls   so   it   will   fill   in   with   the   path
                  strPath = String(MAX_PATH, 0)
    
                  'Retrieves   the   path   selected,   places   in   the   null
                    'character   filled   string
                  lngResult = SHGetPathFromIDList(lngIDList, strPath)
    
                  'Frees   memory
                  Call CoTaskMemFree(lngIDList)
    
                  'Find   the   first   instance   of   a   null   character,
                    'so   we   can   get   just   the   path
                  intNull = InStr(strPath, vbNullChar)
                  'Greater   than   0   means   the   path   exists...
                  If intNull > 0 Then
                          'Set   the   value
                          strPath = Left(strPath, intNull - 1)
                  End If
          End If
    
          'Return   the   path   name
          BrowseForFolder = strPath
          Exit Function     'Abort
    
ehBrowseForFolder:
    
          'Return   no   value
          BrowseForFolder = Empty
    
  End Function
    
 
Private Sub Command1_Click()

Dim one_line, name, phone_no, filename As String
Dim l, i As Integer


If Text2.Text <> "" And Text1.Text <> "" Then
Open Text1.Text For Input As #1
i = 0

Do While Not EOF(1)
  
  Line Input #1, one_line
 ' MsgBox one_line
  For l = 1 To Len(one_line)
     If (Mid(one_line, l, 1) = Chr(9)) Then
       name = Mid(one_line, 1, l - 1)
       phone_no = Mid(one_line, l + 1)
       'MsgBox phone_no
     End If
  Next l
  'Text3.Text = Text3.Text & name & Chr(9) & phone_no & Chr(13) & Chr(10)
  If i > 99 Then
    filename = Text2.Text & "\phb0" & CStr(i) & ".vcf"
  End If
  If i < 100 Then
    filename = Text2.Text & "\phb00" & CStr(i) & ".vcf"
  End If
  If i < 10 Then
    filename = Text2.Text & "\phb000" & CStr(i) & ".vcf"
  End If
  
  
  
  Open filename For Output As #2
  
  Print #2, "BEGIN:VCARD"
  Print #2, "VERSION:2.1"
  Print #2, "N;CHARSET=UTF-8;ENCODING=QUOTED-PRINTABLE:" & UTF8EncodeURI(name)
 ' Print #2, "FN;CHARSET=UTF-8:" & name
  Print #2, "TEL;CELL;VOICE:" & phone_no
  Print #2, "END:VCARD"
  Close (2)
  i = i + 1
Loop

Close (1)
'Command1.Caption = "处理完毕！"
MsgBox "处理完毕！"
End If
End Sub

Private Sub Form_Load()
Text1.Locked = True
Text2.Locked = True

Label3.Caption = "请按“通讯录文本文件”选择文本文件，请按手机目标文件夹选择手机目标‘Contacts’文件夹。按开始转换生成有关手机能导入的文件。通讯录文本文件格式为姓名+TAB制表符+手机号换行。"


End Sub

Private Sub Label1_Click()
    Dim one_line As String
   
    Text3.Text = ""
    ComDlg.CancelError = True
    On Error GoTo Cancel
    ComDlg.Flags = cdlOFNOverwritePrompt + cdlOFNPathMustExist + cdlOFNNoReadOnlyReturn
    ComDlg.DialogTitle = "通讯录文本文件"
    ComDlg.Filter = "TextFiles(*.txt)|*.txt"
    ComDlg.FilterIndex = 2
    
    ComDlg.ShowOpen
    Text1.Text = ComDlg.filename
    Open Text1.Text For Input As 1
    Do While Not EOF(1)
    Line Input #1, one_line
   ' MsgBox one_line
    Text3.Text = Text3.Text & one_line & Chr(13) & Chr(10)
    Loop
Close (1)
    
Cancel:
End Sub

Private Sub Label2_Click()
  Text2.Text = BrowseForFolder(Me.hWnd, "请选择手机目标文件夹:")
End Sub
 ''''''''''''''''''''''''''''' 编码代码源于 因特网
    Function UTF8EncodeURI(szInput)
        Dim wch, uch, szRet
        Dim x
        Dim nAsc, nAsc2, nAsc3

        If szInput = "" Then
            UTF8EncodeURI = szInput
            Exit Function
        End If

        For x = 1 To Len(szInput)
            wch = Mid(szInput, x, 1)
            nAsc = AscW(wch)

            If nAsc < 0 Then nAsc = nAsc + 65536

            If (nAsc And &HFF80) = 0 Then
                szRet = szRet & wch
            Else
                If (nAsc And &HF000) = 0 Then
                    uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
                    szRet = szRet & uch
                Else
                    uch = "=" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "=" & _
                    Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "=" & _
                    Hex(nAsc And &H3F Or &H80)
                    szRet = szRet & uch
                End If
            End If
        Next

        UTF8EncodeURI = szRet
    End Function

    Function GBKEncodeURI(szInput)
        Dim i As Long
        Dim x() As Byte
        Dim szRet As String

        szRet = ""
        x = StrConv(szInput, vbFromUnicode)
        For i = LBound(x) To UBound(x)
            szRet = szRet & "%" & Hex(x(i))
        Next
        GBKEncodeURI = szRet
    End Function

''''''''''''''''''''''''''''' 编码代码源于 因特网