module1.bas

软件用到的技巧：透明窗体

Attribute VB_Name = "Module1"
Option Explicit

Public MdbPath As String
Public AllBaifangOldSqltext As String
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Const HWND_TOPMOST = -1
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOZORDER = &H8
Public form17show As Boolean
Public form2show As Boolean
Public form1show As Boolean
Public form3show As Boolean
Public form4show As Boolean
Public form5show As Boolean
Public frmshowallrenshow As Boolean
Public form6show As Boolean
Public AllBaiFangShow As Boolean
Public form8show As Boolean
Public form10show As Boolean
Public form11show As Boolean
Public form13show As Boolean
Public form12show As Boolean
Public FrmRenAddShow As Boolean
Public FrmUrlsEditShow As Boolean

Public StopToExcel As Boolean
Public ListNum As Long
''''''''''''''''''''下面这段代码用API打开文件对话框的声明.
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
''''''''''''''''''''上面这段代码用于声明用API打开文件对话框的声明.
' Public Sub daochuyidong()
'On Error GoTo errorcode
'    Form11.Label1.Caption = "正在建立数据库联接 ... "
'    Dim db As Database
'    Dim rs As Recordset
'    Dim num As String
'    Set db = OpenDatabase(MdbPath)
'    Form11.Label1.Caption = "正在打开数据库文件 ... "
'    Set rs = db.OpenRecordset("select * from temp")
'    DoEvents
 '   Do Until (rs.EOF = True)
  '      rs.Delete
   '     rs.MoveFirst
    '    DoEvents
'    Loop
'    DoEvents
'    If form11show = True Then
'        Form11.Label1.Caption = "正在提取并写入临时数据库..."
'    End If
'    rs.Close
'    Set rs = db.OpenRecordset("select * from ren ")
'    Dim db2 As Database
'    Dim rs2 As Recordset
'    Set db2 = OpenDatabase(MdbPath)
 '   Set rs2 = db.OpenRecordset("select * from temp")
    
    
    
'    If rs.RecordCount > 0 Then
'    Do Until (rs.EOF = True)
'        'If Trim(rs!手机号码) <> "" Then
'            If Len(Trim(rs!手机号码)) >= 11 Then
'                num = Left(Trim(rs!手机号码), 11)
'                    If Left(num, 3) = "135" Or Left(num, 3) = "136" Or Left(num, 3) = "137" Or Left(num, 3) = "138" Or Left(num, 3) = "139" Or Left(num, 3) = "159" Then
'                        rs2.AddNew
'                        rs2!numbs = num
'                        rs2.Update
'                    End If
'            End If
'        'End If
'        rs.MoveNext
'    Loop
'    End If
'    Form11.Label1.Caption = "已经生成临时库完毕..."
    
    
    
    
    
    
    
'    Form11.Label1.Caption = "正在准备 TXT 文件输出 ... "
'    If Dir(Form11.Text1.Text) <> "" Then
'        If MsgBox("用于输出的文件：AllTelNums.txt 已经存在，确定替换吗？替换将清除原文件中的所有的现存数据。并且不可恢复。", vbQuestion + vbYesNo, "文件将要被替换，严重警告！") = vbYes Then
'            Kill Form11.Text1.Text
'        Else
'            MsgBox "数据输出目标文件已经存在，没有进行替换。数据没有导出。", vbInformation, "导出中断"
'                    Form11.Label1.Caption = "取消了导出，导出到文本文件的操作中断执行。 ..."

'            Exit Sub
           
'        End If
'    End If
'        Dim fn As Integer
'        fn = FreeFile
'        Open Form11.Text1.Text For Append As #fn
'        rs.Close
'        Set rs = db.OpenRecordset("select * from temp")
'        Do Until (rs.EOF = True)
'            Print #fn, rs!numbs
'            rs.MoveNext
'            DoEvents
'        Loop
'        Form11.Label1.Caption = "已经完成移动号码的导出，共 " & rs.RecordCount & "个手机号码。"
'        Close #fn
'        rs.Close
'        Set rs = Nothing
'        db.Close
'        Set db = Nothing
'        Exit Sub
'errorcode:
'If Err.Number <> 0 Then
'    MsgBox "错误：" & Err.Number & vbCrLf & Err.Description, vbInformation, "出现了运行错误"
'End If
'End Sub
Public Sub ShowAllBaiFang(sqlstr As String)
    On Error GoTo ddd:
    If Trim(sqlstr) = "" Then
        MsgBox "传查询的SQL语句失败！语句为空。", vbInformation, "sql语句为空"
        Exit Sub
    End If
    'AllBaiFang.Label7.Caption = "正在打开数据库 ..."
    'AllBaiFang.Label3.Caption = "正在加载数据库 ..."
    AllBaiFang.Frame1.Width = AllBaiFang.Label3.Width + 300
    Dim db As Database
    Dim rs As Recordset
    Set db = OpenDatabase(MdbPath)
    Set rs = db.OpenRecordset(sqlstr)
    AllBaiFang.MSFlexGrid1.Clear
    AllBaiFang.MSFlexGrid1.Rows = 1
    AllBaiFang.MSFlexGrid1.Refresh
    If rs.RecordCount = 0 Then
        'MsgBox "SQL语句查询出现了错误，返回结果为空。或数据库中根本就没有符合条件的记录。", vbInformation, "返回记录集为空"
        rs.Close
        db.Close
        Set rs = Nothing
        Set db = Nothing
        AllBaiFang.Label7.Caption = "数据库为空，已经关闭。"
        AllBaiFang.Label3.Caption = "数据库为空。"
            'AllBaiFang.Label3.Caption = "查找到的集合为空，请选择 刷新 按钮来重新加载信息 ... "
        AllBaiFang.Label6.Caption = ""
        AllBaifangOldSqltext = sqlstr
        AllBaiFang.Frame1.Width = AllBaiFang.Label3.Width + 300
        Exit Sub
    ElseIf rs.RecordCount > 0 Then
        AllBaiFang.Caption = "正在加载拜访记录 请稍候 ..."
        AllBaiFang.Enabled = False
        rs.MoveLast
        rs.MoveFirst
        AllBaiFang.MSFlexGrid1.Rows = rs.RecordCount + 1
        Dim i As Integer
        AllBaiFang.MSFlexGrid1.TextMatrix(0, 0) = "ID"
        AllBaiFang.MSFlexGrid1.TextMatrix(0, 1) = "企业ID号"
        AllBaiFang.MSFlexGrid1.TextMatrix(0, 2) = "企业名称"
        AllBaiFang.MSFlexGrid1.TextMatrix(0, 3) = "拜访时间"
        AllBaiFang.MSFlexGrid1.TextMatrix(0, 4) = "受访人"
        AllBaiFang.MSFlexGrid1.TextMatrix(0, 5) = "拜访人"
        AllBaiFang.MSFlexGrid1.TextMatrix(0, 6) = "拜访内容和总结"
        AllBaiFang.Label7.Caption = "正在读取数据："
        AllBaiFang.MSFlexGrid1.ColWidth(0) = 500
        AllBaiFang.MSFlexGrid1.ColWidth(1) = 800
        AllBaiFang.MSFlexGrid1.ColWidth(2) = 3000
        AllBaiFang.MSFlexGrid1.ColWidth(3) = 1200
        AllBaiFang.MSFlexGrid1.ColWidth(4) = 1500
        AllBaiFang.MSFlexGrid1.ColWidth(5) = 1000
        'AllBaiFang.MSFlexGrid1.ColWidth(6) = 5000'因为为了尽量显示文字，此处已经在窗体的resize事件中用代码设置了，这里的就不用这句了。
            
        For i = 1 To rs.RecordCount
            AllBaiFang.MSFlexGrid1.TextMatrix(i, 0) = rs!id

            AllBaiFang.MSFlexGrid1.TextMatrix(i, 1) = rs!企业ID号

                Dim Db2 As Database
                Dim rs2 As Recordset
                Set Db2 = OpenDatabase(MdbPath)
                Set rs2 = Db2.OpenRecordset("select * from com where id=" & rs!企业ID号)
                If rs2.RecordCount = 1 Then
                    AllBaiFang.MSFlexGrid1.TextMatrix(i, 2) = rs2!企业名称
                ElseIf rs2.RecordCount = 0 Then
                    AllBaiFang.MSFlexGrid1.TextMatrix(i, 2) = "(没有找到拜访记录的归属商家。)"
                End If
                rs2.Close
                Db2.Close
                Set rs2 = Nothing
                Set Db2 = Nothing
            AllBaiFang.MSFlexGrid1.TextMatrix(i, 3) = Format(rs!拜访时间, "yyyy-MM-dd")

            AllBaiFang.MSFlexGrid1.TextMatrix(i, 4) = rs!受访人
            AllBaiFang.MSFlexGrid1.TextMatrix(i, 5) = rs!拜访人
            AllBaiFang.MSFlexGrid1.TextMatrix(i, 6) = rs!内容
            
                    AllBaiFang.Label6.Caption = "" & i & " / " & rs.RecordCount
            rs.MoveNext
            DoEvents
        Next i
        AllBaiFang.Caption = "拜访记录列表 " & "（" & rs.RecordCount & "）"
        rs.Close
        db.Close
        Set rs = Nothing
        Set db = Nothing
        AllBaiFang.Label3.Caption = sqlstr
        AllBaifangOldSqltext = sqlstr
        AllBaiFang.Frame1.Width = AllBaiFang.Label3.Width + 300
        AllBaiFang.Label6.Caption = ""
        AllBaiFang.Label7.Caption = ""
        AllBaiFang.Enabled = True
    End If
    Exit Sub
ddd:
    MsgBox Err.Number & ":" & Err.Description, vbCritical + vbOKOnly
End Sub
Public Sub ShowForm4()
On Error GoTo from4nothing
    If form4show = True Then
        Form4.SetFocus
    End If
    Exit Sub
from4nothing:
    If form4show = True Then
        Unload Form4
    End If
End Sub
Public Sub ShowAllRen(sqlstr As String)
On Error GoTo showallrenerror
    If sqlstr = "" Then
        Exit Sub
    End If
    Dim db As Database
    Dim rs As Recordset
    Set db = OpenDatabase(MdbPath)
    Set rs = db.OpenRecordset(sqlstr)
    If rs.RecordCount = 0 Then
        FrmShowAllRen.MSFlexGrid1.Clear
        FrmShowAllRen.MSFlexGrid1.Rows = 1
        FrmShowAllRen.Caption = "联系人列表 （共 0 个）"
        Exit Sub
    End If

    FrmShowAllRen.Caption = "正在读取联系人数据库，请稍候 ... "
    FrmShowAllRen.Label1.Caption = "正在读取联系人数据库，请稍候 ... "
    FrmShowAllRen.Frame1.Width = FrmShowAllRen.Label1.Width + 300
    FrmShowAllRen.Enabled = False
    FrmShowAllRen.MSFlexGrid1.Clear
    FrmShowAllRen.MSFlexGrid1.Cols = 16
    FrmShowAllRen.MSFlexGrid1.RowHeight(0) = 300
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 0) = "ID"
    FrmShowAllRen.MSFlexGrid1.ColWidth(0) = 500
    
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 1) = "姓名"
    FrmShowAllRen.MSFlexGrid1.ColWidth(1) = 1000
    
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 2) = "助记码"
    FrmShowAllRen.MSFlexGrid1.ColWidth(2) = 1000
    
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 3) = "性别"
    FrmShowAllRen.MSFlexGrid1.ColWidth(3) = 500
    
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 4) = "所属企业"
    FrmShowAllRen.MSFlexGrid1.ColWidth(4) = 2500
    
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 5) = "手机号码"
    FrmShowAllRen.MSFlexGrid1.ColWidth(5) = 1500
    
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 6) = "小灵通号码"
    FrmShowAllRen.MSFlexGrid1.ColWidth(6) = 1500
    
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 7) = "部门"
    FrmShowAllRen.MSFlexGrid1.ColWidth(7) = 1000
    
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 8) = "担任职务"
    FrmShowAllRen.MSFlexGrid1.ColWidth(8) = 1000
    
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 9) = "办公电话"
    FrmShowAllRen.MSFlexGrid1.ColWidth(9) = 1000
    
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 10) = "办公传真"
    FrmShowAllRen.MSFlexGrid1.ColWidth(10) = 1000
    
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 11) = "QQ号码"
    FrmShowAllRen.MSFlexGrid1.ColWidth(11) = 1000
    
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 12) = "电子信箱"
    FrmShowAllRen.MSFlexGrid1.ColWidth(12) = 2500
    
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 13) = "家庭电话"
    FrmShowAllRen.MSFlexGrid1.ColWidth(13) = 1000
    
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 14) = "家庭地址"
    FrmShowAllRen.MSFlexGrid1.ColWidth(14) = 2500
    
    FrmShowAllRen.MSFlexGrid1.TextMatrix(0, 15) = "其他说明"
    FrmShowAllRen.MSFlexGrid1.ColWidth(15) = 2500
    Dim r As Integer
    If rs.RecordCount > 0 Then
        rs.MoveLast
        rs.MoveFirst
    End If
    r = 1