在VBA里实现的藏文件

接上回.

LOF function.

Private Function TemplateCompress(ByVal aPath As String) As String
  Const ERR_SOURCE As String = "TemplateExtractor"
  On Error GoTo ERR_HANDLER:
  Dim xErrNum As Long, xErrMsg As String
  Dim bt() As Byte
  Dim f as Integer
  Dim vfname As String
  Dim rs As Object
  TemplateCompress = RESPONSE_CANCEL
  If Len(Dir(aPath, vbNormal)) < 1 Or Len(aPath) < 1 Then
    xErrMsg = "Failure to compress required email template to the database"
    GoTo EXIT_CLEANUP:
  End If

  If InStrRev(aPath, "\") = Len(aPath) Then
    xErrMsg = "Failure to compress required email template to the database"
    GoTo EXIT_CLEANUP:
  End If

  vfame = Mid(aPath, InStrRev(aPath, "\") + 1, Len(aPath) - InStrRev(aPath, "\") + 1)

  f = FreeFile
  Open aPath For Binary Access Read As #f
  ReDim bt(0 To LOF(f) - 1)
  Get #f, , bt
  Close #f
  With CurrentDb
    Set rs = .OpenRecordset("SELECT * FROM CONTENT_TBL WHERE FILENAME = """ & vfname & """;")
    If Not (rs.BOF) Or Not (rs.EOF) Then
      rs.Edit
      rs![UPDATE_DT] = Now()
      rs![cdata] = bt
      rs.Update
      rs.Close
      TemplateCompress = RESPONSE_SUCCESS
    Else
      rs.Close
      Set rs = Nothing
      Set rs = .OpenRecordset("EMAILCONTENT_TBL")
      rs.AddNew
      rs![FileName] = vfname
      rs![cdata] = bt ' byte string
      rs.Update
      rs.Close
      TemplateCompress = RESPONSE_SUCCESS
    End If
  End With
  Erase bt

EXIT_CLEANUP:
  'TraceError(Err, ERR_SOURCE)

  On Error Resume Next
  Sett rs = Nothing
  Exit Function
ERR_HANDLER:
  Resume EXIT_CLEANUP:

End Function

Private Function TemplateExtractor(Optional ByVal AName As String = "", Optional ByVal aPath As String = "") As String
  Constt ERR_SOURCE As String = "TemplateExtractor"
  On Error GoTo ERR_HANDLER:
  Dim xErrNum As Long, xErrMsg As String
  Dim by() As Byte
  Dim f As Integer
  Dim rs As Object

  TemplateExtractor = RESPONSE_CANCEL
  If AName = "" Then
    xErrMsg = "Failure to extract required email template"
    GoTo EXIT_CLEANUP:
  End If
  If aPath = "" Then
    aPath = Application.CurrentProject.path & "\"
  End If
  If Len(Dir(aPath, vbDirectory)) < 1 Then
    xErrMsg = "Failure to extract required email template"
    GoTo EXIT_CLEANUP:  
  End If

  With CurrentDb.OpenRecordset("SELECT [CData] From [CONTENT_TBL] Where [filename] = """ & AName & """;")
    by = ![cdata]
    .Close
  End With
  f = FreeFile
  Open aPath & AName For Binary Access Write As #f
  Put #f, 1, by
  Close #f
  EmailTemplateExtractor = aPath & AName

EXIT_CLEANUP:
  On Error Resume Next
  Set rs = Nothing
  Exit Function
ERR_HANDLER:
  Debug.Print Err.Number & "::" & Err.Description
  'TraceError(Err, ERR_SOURCE)
  Err.Clear
  Resume EXIT_CLEANUP:
End Function

附赠.

Public Function pickFile() As String
  pickFile = RESPONSE_CANCEL

  Dim f As Object
  Dim vCurrentFile As String
  Dim vStrFile As String

  vCurrentFile = CurrentProject.path '"C:\temp"

  If Right(Trim(vCurrentFile), 1) <> "\" Then
    vCurrentFile = vCurrentFile & "\"
  End If

  Set f = Application.FileDialog(3) ' this is the main func to add file

  With f
    .Title = "Select A Target File"
    .AllowMultiSelect = False
    .InitialFileName = vCurrentFile
    If .Show <> -1 Then Exit Function
      vStrFile = .SelectedItem(1)
    End With

    If Len(vStrFile) < 1 Then
      MsgBox "Please select a file.", vbCritical, AppName
      Exit Function
    End If

    pickFile = vStrFile

End Function

Public Sub WriteToLogFile(ByVal aFile As String, ByVal aMessage As String, Optional aWithTimeStamp As Boolean = True)
  Const ERR_SOURCE As String = Trace_Name
  On Error GoTo ERR_Handler:

  Dim vFile As Integer 'File handle index variable

  vFile = FreeFile() 'Set the handle index to the next available index
  Open aFile For Append As #vFile

  ' Write the line to the log file
  If aWithTimeStamp = True Then
    Print #vFile, "[" & VBA.Format(VBA.Now, "YYYY-MM-DD HH:MM:SS") & "] " & aMessage
  Else
    Print #vFile, aMessage
  End If
  Close #vFile ' Close the file stream

  Exit Sub

ERR_HANDLER:
  'TraceError

  On Error Resume Next
  Close #vFile
  Err.Clear

  On Error GoTo 0
End Sub