Skip to content

Commit

Permalink
cleanup
Browse files Browse the repository at this point in the history
  • Loading branch information
@bkidwell
bkidwell committed Apr 5, 2013
1 parent b9408b6 commit 9a12e36
Showing 1 changed file with 34 additions and 34 deletions.
68 changes: 34 additions & 34 deletions AppCodeImportExport.bas 100755 → 100644
View file
@@ -1,6 +1,3 @@
Option Compare Database
Option Explicit

' Access Module `AppCodeImportExport` ' Access Module `AppCodeImportExport`
' ----------------------------------- ' -----------------------------------
' '
Expand Down Expand Up @@ -32,6 +29,8 @@ Option Explicit
' * Maybe integrate into a dialog box triggered by a menu item. ' * Maybe integrate into a dialog box triggered by a menu item.
' * Warning of destructive overwrite. ' * Warning of destructive overwrite.


Option Compare Database
Option Explicit


' -------------------------------- ' --------------------------------
' List of lookup tables that are part of the program rather than the ' List of lookup tables that are part of the program rather than the
Expand All @@ -43,6 +42,11 @@ Option Explicit


Private Const INCLUDE_TABLES = "" Private Const INCLUDE_TABLES = ""


' --------------------------------
' Structures
' --------------------------------

' Structure to track buffered reading or writing of binary files
Private Type BinFile Private Type BinFile
file_num As Integer file_num As Integer
file_len As Long file_len As Long
Expand All @@ -58,19 +62,23 @@ End Type
' Constants ' Constants
' -------------------------------- ' --------------------------------


' Constants for Scripting.FileSystemObject API
Const ForReading = 1, ForWriting = 2, ForAppending = 8 Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateTrue = -1, TristateFalse = 0, TristateUseDefault = -2 Const TristateTrue = -1, TristateFalse = 0, TristateUseDefault = -2


' -------------------------------- ' --------------------------------
' Module variables ' Module variables
' -------------------------------- ' --------------------------------


Private UsingUcs2_Result As String ' Does the current database file write UCS2-little-endian when exporting
' Queries, Forms, Reports, Macros
Private UsingUcs2 As Boolean


' -------------------------------- ' --------------------------------
' Beginning of main functions of this module ' Beginning of main functions of this module
' -------------------------------- ' --------------------------------


' Open a binary file for reading (mode = 'r') or writing (mode = 'w').
Private Function BinOpen(file_path As String, mode As String) As BinFile Private Function BinOpen(file_path As String, mode As String) As BinFile
Dim f As BinFile Dim f As BinFile


Expand Down Expand Up @@ -102,6 +110,7 @@ Private Function BinOpen(file_path As String, mode As String) As BinFile
BinOpen = f BinOpen = f
End Function End Function


' Buffered read one byte at a time from a binary file.
Private Function BinRead(ByRef f As BinFile) As Integer Private Function BinRead(ByRef f As BinFile) As Integer
If f.at_eof = True Then If f.at_eof = True Then
BinRead = 0 BinRead = 0
Expand All @@ -128,6 +137,7 @@ Private Function BinRead(ByRef f As BinFile) As Integer
End If End If
End Function End Function


' Buffered write one byte at a time from a binary file.
Private Sub BinWrite(ByRef f As BinFile, b As Integer) Private Sub BinWrite(ByRef f As BinFile, b As Integer)
Mid(f.buffer, f.buffer_pos + 1, 1) = Chr(b) Mid(f.buffer, f.buffer_pos + 1, 1) = Chr(b)
f.buffer_pos = f.buffer_pos + 1 f.buffer_pos = f.buffer_pos + 1
Expand All @@ -137,6 +147,7 @@ Private Sub BinWrite(ByRef f As BinFile, b As Integer)
End If End If
End Sub End Sub


' Close binary file.
Private Sub BinClose(ByRef f As BinFile) Private Sub BinClose(ByRef f As BinFile)
If f.mode = "w" And f.buffer_pos > 0 Then If f.mode = "w" And f.buffer_pos > 0 Then
f.buffer = Left(f.buffer, f.buffer_pos) f.buffer = Left(f.buffer, f.buffer_pos)
Expand All @@ -145,15 +156,18 @@ Private Sub BinClose(ByRef f As BinFile)
Close f.file_num Close f.file_num
End Sub End Sub


' Path of the current database file.
Private Function ProjectPath() As String Private Function ProjectPath() As String
ProjectPath = CurrentProject.Path ProjectPath = CurrentProject.Path
If Right(ProjectPath, 1) <> "\" Then ProjectPath = ProjectPath & "\" If Right(ProjectPath, 1) <> "\" Then ProjectPath = ProjectPath & "\"
End Function End Function


' Path of single temp file used by any function in this module.
Private Function TempFile() As String Private Function TempFile() As String
TempFile = ProjectPath() & "AppCodeImportExport.tempdata" TempFile = ProjectPath() & "AppCodeImportExport.tempdata"
End Function End Function


' Export a database object with optional UCS2-to-UTF-8 conversion.
Private Sub ExportObject(obj_type_num As Integer, obj_name As String, file_path As String, _ Private Sub ExportObject(obj_type_num As Integer, obj_name As String, file_path As String, _
Optional Ucs2Convert As Boolean = False) Optional Ucs2Convert As Boolean = False)


Expand All @@ -166,6 +180,7 @@ Private Sub ExportObject(obj_type_num As Integer, obj_name As String, file_path
End If End If
End Sub End Sub


' Import a database object with optional UTF-8-to-UCS2 conversion.
Private Sub ImportObject(obj_type_num As Integer, obj_name As String, file_path As String, _ Private Sub ImportObject(obj_type_num As Integer, obj_name As String, file_path As String, _
Optional Ucs2Convert As Boolean = False) Optional Ucs2Convert As Boolean = False)


Expand All @@ -177,6 +192,7 @@ Private Sub ImportObject(obj_type_num As Integer, obj_name As String, file_path
End If End If
End Sub End Sub


' Binary convert a UCS2-little-endian encoded file to UTF-8.
Private Sub ConvertUcs2Utf8(source As String, dest As String) Private Sub ConvertUcs2Utf8(source As String, dest As String)
Dim f_in As BinFile, f_out As BinFile Dim f_in As BinFile, f_out As BinFile
Dim in_low As Integer, in_high As Integer Dim in_low As Integer, in_high As Integer
Expand Down Expand Up @@ -206,6 +222,7 @@ Private Sub ConvertUcs2Utf8(source As String, dest As String)
BinClose f_out BinClose f_out
End Sub End Sub


' Binary convert a UTF-8 encoded file to UCS2-little-endian.
Private Sub ConvertUtf8Ucs2(source As String, dest As String) Private Sub ConvertUtf8Ucs2(source As String, dest As String)
Dim f_in As BinFile, f_out As BinFile Dim f_in As BinFile, f_out As BinFile
Dim in_1 As Integer, in_2 As Integer, in_3 As Integer Dim in_1 As Integer, in_2 As Integer, in_3 As Integer
Expand Down Expand Up @@ -237,21 +254,12 @@ Private Sub ConvertUtf8Ucs2(source As String, dest As String)
BinClose f_out BinClose f_out
End Sub End Sub


Public Sub TestExportUcs2() ' Determine if this database imports/exports code as UCS-2-LE. (Older file
ExportObject acForm, "example_form", ProjectPath & "output.txt", True ' formats cause exported objects to use a Windows 8-bit character set.)
ConvertUtf8Ucs2 ProjectPath & "output.txt", ProjectPath & "output_ucs2.txt" Private Sub InitUsingUcs2()
End Sub

' Determine if this database imports/exports code as UCS-2-LE
Private Function UsingUcs2() As Boolean
Dim obj_name As String, i As Integer, obj_type As Variant, fn As Integer, bytes As String Dim obj_name As String, i As Integer, obj_type As Variant, fn As Integer, bytes As String
Dim obj_type_split() As String, obj_type_name As String, obj_type_num As Integer Dim obj_type_split() As String, obj_type_name As String, obj_type_num As Integer
Dim db As Object ' DAO.Database Dim db As Object ' DAO.Database

If UsingUcs2_Result <> "" Then
UsingUcs2 = (UsingUcs2_Result = "1")
Exit Function
End If


If CurrentDb.QueryDefs.Count > 0 Then If CurrentDb.QueryDefs.Count > 0 Then
obj_type_num = acQuery obj_type_num = acQuery
Expand All @@ -275,9 +283,8 @@ Private Function UsingUcs2() As Boolean


If obj_name = "" Then If obj_name = "" Then
' No objects found that can be used to test UCS2 versus UTF-8 ' No objects found that can be used to test UCS2 versus UTF-8
UsingUcs2_Result = "1"
UsingUcs2 = True UsingUcs2 = True
Exit Function Exit Sub
End If End If


Application.SaveAsText obj_type_num, obj_name, TempFile() Application.SaveAsText obj_type_num, obj_name, TempFile()
Expand All @@ -286,18 +293,11 @@ Private Function UsingUcs2() As Boolean
bytes = " " bytes = " "
Get fn, 1, bytes Get fn, 1, bytes
If Asc(Mid(bytes, 1, 1)) = &HFF And Asc(Mid(bytes, 2, 1)) = &HFE Then If Asc(Mid(bytes, 1, 1)) = &HFF And Asc(Mid(bytes, 2, 1)) = &HFE Then
UsingUcs2_Result = "1"
UsingUcs2 = True UsingUcs2 = True
Else Else
UsingUcs2_Result = "0"
UsingUcs2 = False UsingUcs2 = False
End If End If
Close fn Close fn
End Function

Public Sub TestUsingUcs2()
UsingUcs2_Result = ""
Debug.Print UsingUcs2()
End Sub End Sub


' Create folder `Path`. Silently do nothing if it already exists. ' Create folder `Path`. Silently do nothing if it already exists.
Expand All @@ -316,15 +316,15 @@ DelIfNotExist_Noop:
On Error GoTo 0 On Error GoTo 0
End Sub End Sub


' Erase all *.data and *.txt files in `Path`. ' Erase all *.`ext` files in `Path`.
Private Sub ClearTextFilesFromDir(Path As String, Ext As String) Private Sub ClearTextFilesFromDir(Path As String, Ext As String)
Dim fso As Object Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject") Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(Path) Then Exit Sub If Not fso.FolderExists(Path) Then Exit Sub


On Error GoTo ClearTextFilesFromDir_noop On Error GoTo ClearTextFilesFromDir_noop
If Dir(Path & "*." & Ext) <> "" Then If Dir(Path & "*." & Ext) <> "" Then
Kill Path & "*.data" & Ext Kill Path & "*." & Ext
End If End If
ClearTextFilesFromDir_noop: ClearTextFilesFromDir_noop:


Expand All @@ -338,9 +338,6 @@ End Sub
Private Sub SanitizeTextFiles(Path As String, Ext As String) Private Sub SanitizeTextFiles(Path As String, Ext As String)
Dim fso, InFile, OutFile, FileName As String, txt As String, obj_name As String Dim fso, InFile, OutFile, FileName As String, txt As String, obj_name As String


Dim ForReading As Long

ForReading = 1
Set fso = CreateObject("Scripting.FileSystemObject") Set fso = CreateObject("Scripting.FileSystemObject")


FileName = Dir(Path & "*." & Ext) FileName = Dir(Path & "*." & Ext)
Expand Down Expand Up @@ -402,6 +399,7 @@ Public Sub ExportAllSource()
Dim tblName As Variant Dim tblName As Variant


Set db = CurrentDb Set db = CurrentDb
InitUsingUcs2


source_path = ProjectPath() & "source\" source_path = ProjectPath() & "source\"
MkDirIfNotExist source_path MkDirIfNotExist source_path
Expand Down Expand Up @@ -443,7 +441,7 @@ Public Sub ExportAllSource()
If obj_type_label = "modules" Then If obj_type_label = "modules" Then
ucs2 = False ucs2 = False
Else Else
ucs2 = UsingUcs2() ucs2 = UsingUcs2
End If End If
ExportObject obj_type_num, doc.Name, obj_path & doc.Name & ".bas", ucs2 ExportObject obj_type_num, doc.Name, obj_path & doc.Name & ".bas", ucs2
End If End If
Expand Down Expand Up @@ -477,6 +475,7 @@ Public Sub ImportAllSource()
Dim ucs2 As Boolean Dim ucs2 As Boolean


Set db = CurrentDb Set db = CurrentDb
InitUsingUcs2


source_path = ProjectPath() & "source\" source_path = ProjectPath() & "source\"
MkDirIfNotExist source_path MkDirIfNotExist source_path
Expand All @@ -488,7 +487,7 @@ Public Sub ImportAllSource()
FileName = Dir(obj_path & "*.bas") FileName = Dir(obj_path & "*.bas")
Do Until Len(FileName) = 0 Do Until Len(FileName) = 0
obj_name = Mid(FileName, 1, InStrRev(FileName, ".") - 1) obj_name = Mid(FileName, 1, InStrRev(FileName, ".") - 1)
ImportObject acQuery, obj_name, obj_path & FileName, UsingUcs2() ImportObject acQuery, obj_name, obj_path & FileName, UsingUcs2
FileName = Dir() FileName = Dir()
Loop Loop


Expand Down Expand Up @@ -521,7 +520,7 @@ Public Sub ImportAllSource()
If obj_type_label = "modules" Then If obj_type_label = "modules" Then
ucs2 = False ucs2 = False
Else Else
ucs2 = UsingUcs2() ucs2 = UsingUcs2
End If End If
ImportObject obj_type_num, obj_name, obj_path & FileName, ucs2 ImportObject obj_type_num, obj_name, obj_path & FileName, ucs2
End If End If
Expand Down Expand Up @@ -624,4 +623,5 @@ Private Sub ImportTable(tblName As String, obj_path As String)
rsWrite.Close rsWrite.Close
rs.Close rs.Close
InFile.Close InFile.Close
End Sub End Sub

0 comments on commit 9a12e36

Please sign in to comment.