📄 frmmail.frm
字号:
VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmMail
BorderStyle = 1 'Fixed Single
Caption = "导入导出"
ClientHeight = 3915
ClientLeft = 45
ClientTop = 330
ClientWidth = 5340
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3915
ScaleWidth = 5340
StartUpPosition = 2 '屏幕中心
Begin MSComDlg.CommonDialog cdgFilePath
Left = 1800
Top = 3240
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton cmdFindPath
Height = 285
Left = 3600
Style = 1 'Graphical
TabIndex = 8
Tag = "1017"
Top = 345
UseMaskColor = -1 'True
Width = 285
End
Begin VB.TextBox txtPath
Height = 270
Left = 90
TabIndex = 7
Top = 345
Width = 3495
End
Begin VB.PictureBox pctLine
BackColor = &H00000000&
BorderStyle = 0 'None
ForeColor = &H00000000&
Height = 2160
Left = 1110
ScaleHeight = 2160
ScaleWidth = 15
TabIndex = 5
Top = 1050
Width = 15
End
Begin MSFlexGridLib.MSFlexGrid msgPutItem
Height = 2685
Left = 90
TabIndex = 4
Top = 1020
Width = 3765
_ExtentX = 6641
_ExtentY = 4736
_Version = 393216
FixedCols = 0
BackColorBkg = -2147483643
GridColorFixed = 16777215
AllowBigSelection= 0 'False
GridLines = 0
ScrollBars = 2
SelectionMode = 1
End
Begin VB.CommandButton cmdOKCancelFilter
Caption = "筛选(&F)"
Height = 350
Index = 2
Left = 3960
TabIndex = 3
Top = 1440
UseMaskColor = -1 'True
Width = 1215
End
Begin VB.CommandButton cmdOKCancelFilter
Cancel = -1 'True
Height = 350
Index = 1
Left = 4020
Style = 1 'Graphical
TabIndex = 2
Top = 900
UseMaskColor = -1 'True
Width = 1215
End
Begin VB.CommandButton cmdOKCancelFilter
Default = -1 'True
Height = 350
Index = 0
Left = 4020
Style = 1 'Graphical
TabIndex = 1
Top = 300
UseMaskColor = -1 'True
Width = 1215
End
Begin VB.Label lblImPortTable
AutoSize = -1 'True
Caption = "数据文件夹(&P)"
Height = 180
Index = 1
Left = 90
TabIndex = 6
Top = 75
Width = 1170
End
Begin VB.Label lblImPortTable
AutoSize = -1 'True
Caption = "导出项目(&T)"
Height = 180
Index = 0
Left = 90
TabIndex = 0
Top = 765
Width = 990
End
End
Attribute VB_Name = "frmMail"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
''**********API函数声明***********
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Private mstrWhere(10) As String
Private mintViewId(8) As Integer
Private mListset As ListSet
Private mstrPath As String
Private mintYear As Integer
Private mintStartPeriod As Integer
Private mintEndPeriod As Integer
Private mclsComm As Communication
Private mstrZipTmp As String '压缩临时文件
Private mstrDestFile As String '打包文件
Private Sub cmdFindPath_Click()
With cdgFilePath
.DialogTitle = "导出格式文件"
.InitDir = GetFilePath(txtPath.Text)
.Filter = "金算盘数据导出格式文件(*.ini)|*.ini"
.ShowOpen
If .FileName <> "" Then
txtPath.Text = .FileName
InitByInorOut txtPath.Text
End If
txtPath.SetFocus
End With
End Sub
Private Sub cmdOKCancelFilter_Click(Index As Integer)
Dim blnFlage As Boolean
Dim blnItem(83) As Boolean
Dim intCount As Integer, intCopy As Integer
Dim blnSend As Boolean
Dim strName As String, strFile As String, strINIFile As String
Dim strMailFile As String
blnSend = False
Select Case Index
Case 0 '确认
If Dir(GetFilePath(txtPath.Text), vbDirectory) = "" Then
ShowMsg Me.hwnd, "你所选择的路径不存在，请重新选择！", vbInformation, Me.Caption
txtPath.SetFocus
Exit Sub
End If
mstrZipTmp = "C:\GaMail.tmp"
mstrDestFile = App.Path & "\GaMail.gdm"
strINIFile = txtPath.Text
If CoordinateArray(blnItem) Then
With msgPutItem
For intCount = 2 To .Rows - 1
If blnItem(intCount - 2) Then
strName = Trim(.TextMatrix(intCount, 2))
strFile = GetFilePath(strINIFile) & "\" & VBGetPrivateProfileString(strName, "文件名", strINIFile)
If strFile <> "" Then
If strMailFile <> "" Then
strMailFile = strMailFile & "|" & strFile
Else
strMailFile = strFile
End If
End If
End If
Next intCount
End With
If strMailFile <> "" Then
strMailFile = strMailFile & "|" & strINIFile
End If
SendMail.CompressFile strMailFile, mstrZipTmp
intCopy = CopyFile(mstrZipTmp, mstrDestFile, False)
If intCopy <> 0 Then
If mclsComm.SendFile(mstrDestFile) = 0 Then
blnSend = True
Kill mstrDestFile
End If
End If
Kill mstrZipTmp
If blnSend Then
ShowMsg Me.hwnd, "数据发送成功!", vbInformation + vbOKOnly, App.title
Else
ShowMsg Me.hwnd, "数据发送失败!", vbInformation + vbOKOnly, App.title
End If
End If
Unload Me
Case 1 '取消
Unload Me
End Select
End Sub
Private Sub Form_Load()
Set mclsComm = New Communication
Me.Icon = Utility.GetFormResPicture(139, vbResIcon)
Set cmdOKCancelFilter(0).Picture = GetFormResPicture(1001, vbResBitmap)
Set cmdOKCancelFilter(1).Picture = GetFormResPicture(1002, vbResBitmap)
Set cmdFindPath.Picture = GetFormResPicture(1017, vbResBitmap)
mintViewId(0) = 6
mintViewId(1) = 7
mintViewId(2) = 8
mintViewId(3) = 9
mintViewId(4) = 10
mintViewId(5) = 11
mintViewId(6) = 12
mintViewId(7) = 13
mintViewId(8) = 13
InitGrid
Me.Caption = "数据发送"
lblImPortTable(1).Caption = "发送数据源(&P)"
lblImPortTable(0).Caption = "发送内容(&T)"
txtPath.Text = App.Path & "\Format.ini"
cmdOKCancelFilter(2).Visible = False
InitByInorOut txtPath.Text
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Utility.RemoveFormResPicture (139)
Utility.RemoveFormResPicture (1001)
Utility.RemoveFormResPicture (1002)
Utility.RemoveFormResPicture (1017)
Utility.RemoveFormResPicture (139)
End Sub
Private Sub msgPutItem_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
With msgPutItem
If .Rows > 1 Then
If .MouseCol = 1 And .MouseRow <> 0 Then
.MousePointer = vbCustom
Else
.MousePointer = vbDefault
End If
Else
.MousePointer = vbDefault
End If
If Button = vbLeftButton Then
.AllowBigSelection = False
If .Row <> .MouseRow Then
.Row = .MouseRow
End If
End If
End With
End Sub
Private Sub msgPutItem_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
With msgPutItem
If Button = vbLeftButton Then
If .ColSel > 0 And .MouseRow > 0 And .Row > 0 Then
If x > .ColPos(1) And x < .ColPos(2) Then
If .TextMatrix(.Row, 1) = "" Then
.TextMatrix(.Row, 1) = "√"
Else
.TextMatrix(.Row, 1) = ""
End If
End If
End If
End If
End With
End Sub
Private Function getID() As Integer
With msgPutItem
If .Row > 0 Then
getID = CInt(.TextMatrix(.Row, 0))
Else
getID = -1
End If
End With
End Function
Private Function CoordinateArray(blnItem() As Boolean) As Boolean
Dim intCount As Integer
With msgPutItem
For intCount = 2 To .Rows - 1
If .TextMatrix(intCount, 1) = "√" Then
blnItem(.TextMatrix(intCount, 0)) = True
CoordinateArray = True
Else
blnItem(.TextMatrix(intCount, 0)) = False
End If
Next
End With
End Function
Private Sub InitGrid()
Dim recTemp As rdoResultset
With msgPutItem
.AllowBigSelection = True
.SelectionMode = flexSelectionByRow
.Cols = 3
.ColSel = .Cols - 1
.ColWidth(0) = 0
.ColWidth(1) = 500
.ColWidth(2) = .width - .ColWidth(0) - 100
.FixedRows = 1
.TextMatrix(0, 1) = "选择"
.TextMatrix(0, 2) = "项目"
.AddItem "0" & Chr(9) & "" & Chr(9) & "科目", .Rows
.AddItem "1" & Chr(9) & "" & Chr(9) & "货币", .Rows
.AddItem "2" & Chr(9) & "" & Chr(9) & "部门", .Rows
.AddItem "3" & Chr(9) & "" & Chr(9) & "职员类别", .Rows
.AddItem "4" & Chr(9) & "" & Chr(9) & "职员", .Rows
.AddItem "5" & Chr(9) & "" & Chr(9) & "单位类别", .Rows
.AddItem "6" & Chr(9) & "" & Chr(9) & "单位", .Rows
.AddItem "7" & Chr(9) & "" & Chr(9) & "统计核算", .Rows
.AddItem "8" & Chr(9) & "" & Chr(9) & "项目核算", .Rows
.AddItem "9" & Chr(9) & "" & Chr(9) & "商品性质", .Rows
.AddItem "10" & Chr(9) & "" & Chr(9) & "商品类别", .Rows
.AddItem "11" & Chr(9) & "" & Chr(9) & "商品", .Rows
.AddItem "12" & Chr(9) & "" & Chr(9) & "商品单位", .Rows
.AddItem "13" & Chr(9) & "" & Chr(9) & "货位", .Rows
.AddItem "14" & Chr(9) & "" & Chr(9) & "工程类别", .Rows
.AddItem "15" & Chr(9) & "" & Chr(9) & "工程", .Rows
.AddItem "16" & Chr(9) & "" & Chr(9) & "凭证", .Rows
.AddItem "17" & Chr(9) & "" & Chr(9) & "余额", .Rows
.AddItem "18" & Chr(9) & "" & Chr(9) & "科目期初", .Rows
.AddItem "19" & Chr(9) & "" & Chr(9) & "应收应付余额", .Rows
.AddItem "20" & Chr(9) & "" & Chr(9) & "应收应付期初", .Rows
' .AddItem "21" & Chr(9) & "" & Chr(9) & "现金银行余额", .Rows
.AddItem "22" & Chr(9) & "" & Chr(9) & "银行对帐单", .Rows
.AddItem "23" & Chr(9) & "" & Chr(9) & "银行帐期初", .Rows
.AddItem "24" & Chr(9) & "" & Chr(9) & "固资增加", .Rows
.AddItem "25" & Chr(9) & "" & Chr(9) & "固资减少", .Rows
.AddItem "26" & Chr(9) & "" & Chr(9) & "固资变动", .Rows
' .RemoveItem 12
Set recTemp = gclsBase.BaseDB.OpenResultset("SELECT * FROM ReceiptType") ' WHERE lngReceiptTypeID<>41")
Do While Not recTemp.EOF
.AddItem recTemp!lngReceiptTypeID + 26 & Chr(9) & "" & Chr(9) & recTemp!strReceiptTypeName
recTemp.MoveNext
Loop
pctLine.Left = .Left + 30 + .ColWidth(1)
pctLine.top = .top + .RowPos(0) + 30
pctLine.Height = .Height - 90
Set .MouseIcon = GetFormResPicture(101, vbResCursor)
End With
End Sub
Private Function InitByInorOut(ByVal strFile As String) As Boolean
Dim intCount As Integer
Dim lngResult As Long
Dim strResult As String * 10
With msgPutItem
For intCount = 1 To .Rows - 1
lngResult = GetPrivateProfileSection(.TextMatrix(intCount, 2), strResult, 10, strFile)
If lngResult > 0 Then
.RowHeight(intCount) = .RowHeight(0)
Else
.RowHeight(intCount) = 0
.TextMatrix(intCount, 1) = ""
End If
Next
End With
End Function
'从格式文件中取主键值
Private Function VBGetPrivateProfileString(ByVal strSection As String, ByVal strKey As String, ByVal strFile As String) As String
Dim KeyValue As String
Dim Characters As Long
KeyValue = String$(128, " ")
Characters = GetPrivateProfileString(strSection, strKey, " ", KeyValue, 127, strFile)
If Characters >= 1 Then
KeyValue = Left$(KeyValue, Characters)
Else
KeyValue = ""
End If
VBGetPrivateProfileString = Trim(KeyValue)
End Function
Private Sub txtPath_LostFocus()
If Dir(txtPath.Text) = "" Then
If Me.ActiveControl Is cmdOKCancelFilter(1) Or Me.ActiveControl Is cmdFindPath Then
Exit Sub
End If
ShowMsg Me.hwnd, "你所选择的路径不存在，请重新选择！", vbInformation, Me.Caption
txtPath.SetFocus
Exit Sub
Else
InitByInorOut txtPath.Text
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -