frmmain.frm

将数据从excel导入到SQLSEVER库中

 
End Sub

Private Sub Command2_Click()
  MsgBox (returnChar(35))

End Sub

Private Sub Command3_Click()

 

End Sub

Public Function ExporToExcel(strOpen As String, strAppPath As String, sFileName As String)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(strOpen-sql查询字符串,sFileName-文件名)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
    On Error Resume Next
    Dim Irowcount As Integer
    Dim Icolcount As Integer

    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable

    Dim ExclFileName As String
    Dim i As Integer
    With Rs_Data
        If .State = adStateOpen Then
            .Close
        End If
        .ActiveConnection = conn
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Source = strOpen
        .Open
    End With
    With Rs_Data
        If .RecordCount < 1 Then
            MsgBox ("没有记录!")
            Exit Function
        End If
        '记录总数
        Irowcount = .RecordCount
        '字段总数
        Icolcount = .Fields.count
    End With

    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add
    Set xlSheet = xlBook.Worksheets("sheet1")
    xlApp.Visible = True

    '添加查询语句，导入EXCEL数据
    Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))

    With xlQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
    End With

    xlQuery.FieldNames = True '显示字段名
    xlQuery.Refresh

    With xlSheet
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
        '设标题为黑体字
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
        '标题字体加粗
        .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
        '设表格边框样式
    End With

'    With xlSheet.PageSetup
'        .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称："   ' & Gsmc
'        .CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
'        .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
'        .LeftFooter = "&""楷体_GB2312,常规""&10制表人："
'        .CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
'        .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
'    End With
'
 '   ExclFileName = App.Path & "\Excel\" & Date & sFileName & ".xls"
    ExclFileName = strAppPath & Date & sFileName '& ".xls"
    i = 1
Sign:   If Dir(ExclFileName) <> "" Then
            'Kill ExclFileName
            'ExclFileName = App.Path & "\Excel\" & Date & sFileName & i & ".xls"
            ExclFileName = strAppPath & Date & sFileName & i & ".xls"
            i = i + 1
            GoTo Sign
        End If

'    xlApp.Application.Visible = True      '"交还控制给Excel
'    xlApp.WindowState = xlMaximized
    xlBook.SaveAs (ExclFileName)
    xlApp.Quit
    Set xlApp = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing

    Exit Function
Err_Folder:
    If Err.Number = 1004 Then
        MsgBox Err.Description
        MkDir strAppPath
        Resume
    Else
        Resume Next
    End If
End Function

Private Sub cmd1_Click()
  Dim strsql As String
  Dim path As String
  Dim fileName As String
  Dim temp As String
  Dim i As Integer
  Dim Intlen As Integer
  Dim position As Integer
  Dim tt
  Dim strFields As String
  Dim resutlsql As String
  If listfield.ListCount > 0 Then
    strFields = ""
    For i = 0 To listfield.ListCount - 1
      If listfield.Selected(i) Then
        strFields = strFields + listfield.List(i) + ","
      End If
    Next
    
  Else
    If chk1.Value = True Then
      Exit Sub
    End If
  End If
  CommonDialog1.Filter = "电子表格Excel文件(*.XLS)|*.XLS"
  CommonDialog1.ShowSave
  If CommonDialog1.fileName <> "" Then
    temp = CommonDialog1.fileName
    position = InStrRev(temp, "\")
 
    path = Mid(temp, 1, position)
    fileName = Mid(temp, position + 1, Len(temp) - position)
 
  Else
    MsgBox ("请输入文件名称")
    Exit Sub
  End If
  'path = "e:\vb读写EXCEL例子\"
 ' strsql = "select * from t_user_def"
  If Trim(strFields) <> "" Then
    strFields = Mid(strFields, 1, Len(strFields) - 1)
    strsql = "select " + strFields + " from " + prdbname + ".dbo." + prtable
  End If
  If chk1.Value Then
    strsql = strsql
  Else
    strsql = Trim(txtsql)
  End If
  tt = ExporToExcel(strsql, path, fileName)
End Sub

Private Sub Command4_Click()
  Unload Me
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)

End Sub

Private Sub initListdatabase(strsql As String)
  
    Dim newitem As ListItem
    Dim sValue As String
    Dim rs As New ADODB.Recordset
    Dim cout As Integer
    If strsql = "" Then
      Exit Sub
    End If
 
    listdatabase.BackColor = &H80000018
    listdatabase.ListItems.Clear
    rs.Open strsql, mycon, 1, 3
    If rs.RecordCount > 0 Then
       rs.MoveFirst
       While Not rs.EOF
        sValue = Trim(rs.Fields("dbid").Value)
       
        Set newitem = listdatabase.ListItems.Add(, , sValue, , 0)
        newitem.SubItems(1) = IIf(IsNull(Trim(rs.Fields("dbname").Value)), "", Trim(rs.Fields("dbname").Value))
        rs.MoveNext
       Wend
       rs.Close
       Set rs = Nothing
    Else
      Exit Sub
    End If

 End Sub
 '初始化数据库的所有表
 Private Sub initListtable(strsql As String)
  
    Dim newitem As ListItem
    Dim sValue As String
    Dim rs As New ADODB.Recordset
    Dim cout As Integer
    If strsql = "" Then
      Exit Sub
    End If
 
    listtable.BackColor = &H80000018
    listtable.ListItems.Clear
    rs.Open strsql, mycon, 1, 3
    If rs.RecordCount > 0 Then
       rs.MoveFirst
       While Not rs.EOF
        sValue = Trim(rs.Fields("tbid").Value)
       
        Set newitem = listtable.ListItems.Add(, , sValue, , 0)
        newitem.SubItems(1) = IIf(IsNull(Trim(rs.Fields("tbname").Value)), "", Trim(rs.Fields("tbname").Value))
        rs.MoveNext
       Wend
       rs.Close
       Set rs = Nothing
    Else
      Exit Sub
    End If

 End Sub

Private Sub Form_Load()
   Dim lStyle As Long
        lStyle = SendMessage(listdatabase.hwnd, _
           LVM_GETEXTENDEDLISTVIEWSTYLE, 0, 0)
        lStyle = lStyle Or LVS_EX_FULLROWSELECT
        Call SendMessage(listdatabase.hwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, _
          0, ByVal lStyle)
   Dim tStyle As Long
        tStyle = SendMessage(listtable.hwnd, _
           LVM_GETEXTENDEDLISTVIEWSTYLE, 0, 0)
        tStyle = tStyle Or LVS_EX_FULLROWSELECT
        Call SendMessage(listtable.hwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, _
          0, ByVal tStyle)
    txtIP = "127.0.0.1"
    Me.menuedit.Visible = False
    Me.menufield.Visible = False
    chk1.Value = 1
End Sub

Private Sub listdatabase_ItemClick(ByVal Item As MSComctlLib.ListItem)
  Dim dbname As String
  Dim strsql As String
  If listdatabase.ListItems.count > 0 Then
    dbname = Trim(listdatabase.SelectedItem.SubItems(1))
    prdbname = dbname
    strsql = "select name as tbname,id as tbid from  " + dbname + ".dbo.sysobjects where xtype='U'"
    strsql = strsql + " and name<>'dtproperties'"
    initListtable (strsql)
  End If
End Sub

Private Sub listfield_Click()
'  Dim strFields As String
'  Dim i As Integer
'  Dim index As Integer
'  If listfield.ListCount > 0 Then
'    index = listfield.ListIndex
'
'      If listfield.Selected(index) Then
'        txtsql = txtsql + listfield.List(index) + ","
'      End If
'
'
'  Else
'    Exit Sub
'  End If
End Sub

Private Sub listfield_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

  If Button = 2 Then
        Me.PopupMenu Me.menuedit
  End If
End Sub

Private Sub listimport_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        Me.PopupMenu Me.menufield
  End If
End Sub

Private Sub listtable_ItemClick(ByVal Item As MSComctlLib.ListItem)
  Dim dbId As String
  Dim strsql As String
  Dim rs As New ADODB.Recordset
  If Frame2.Visible = False Then
     Frame2.Visible = True
     If framimport.Visible Then
       framimport.Visible = False
     End If
  End If
  If listfield.ListCount > 0 Then
    listfield.Clear
  End If
  If listtable.ListItems.count > 0 Then
    dbId = Trim(listtable.SelectedItem.Text)
    prtable = Trim(listtable.SelectedItem.SubItems(1))
    strsql = "select name as fieldname from   " + prdbname + ".dbo.syscolumns where id='" + dbId + "'"
    rs.Open strsql, mycon, 1, 3
    If rs.RecordCount > 0 Then
      rs.MoveFirst
      While Not rs.EOF
        listfield.AddItem (Trim(rs.Fields("fieldname").Value))
        rs.MoveNext
      Wend
      rs.Close
      Set rs = Nothing
    End If
  End If
End Sub

Private Sub memuoutport_Click()
   Call cmd1_Click
End Sub

Private Sub menucacel_Click()
  Dim i As Integer
  If listfield.ListCount > 0 Then
     For i = 0 To listfield.ListCount - 1
        listfield.Selected(i) = False
     Next
  End If
End Sub

Private Sub menuselall_Click()
  Dim i As Integer
  If listfield.ListCount > 0 Then
     For i = 0 To listfield.ListCount - 1
        listfield.Selected(i) = True
     Next
  End If
End Sub
'将数字转化成excel文件的列头排序规则，
Private Function returnChar(a As Integer) As String
  Dim strchar As String
  Dim str As String
  Dim strtemp As String
  Dim temp As Integer
  Dim dbcount As Integer
  Dim i As Integer
  ' MsgBox (CStr(9 \ 26))
   ' MsgBox (CStr(35 Mod 26))
  If a > 0 Then
    dbcount = a \ 26 '返回26的倍数
    temp = a Mod 26  '返回余数

    Select Case temp
      Case 1
         str = UCase("A")
      Case 2
         str = UCase("B")
      Case 3
         str = UCase("C")
      Case 4
         str = UCase("D")
      Case 5
         str = UCase("E")
      Case 6
         str = UCase("F")
      Case 7
         str = UCase("G")
      Case 8
         str = UCase("H")
      Case 9
         str = UCase("I")
      Case 10
         str = UCase("J")
      Case 11
         str = UCase("K")
      Case 12
         str = UCase("L")
      Case 13
         str = UCase("M")
      Case 14
         str = UCase("N")
      Case 15
         str = UCase("O")
      Case 16
         str = UCase("P")
      Case 17
         str = UCase("Q")
      Case 18
         str = UCase("R")
      Case 19
         str = UCase("S")
      Case 20
         str = UCase("T")
      Case 21
         str = UCase("U")
      Case 22
         str = UCase("V")
      Case 23
         str = UCase("W")
      Case 24
         str = UCase("X")
      Case 25
         str = UCase("Y")
      Case 26
         str = UCase("Z")
      Case 0
         str = ""
    End Select
    If dbcount > 0 Then
      strtemp = ""
      For i = 1 To dbcount
        strtemp = strtemp + "A"
      Next
      returnChar = UCase(strtemp + str)
    Else
      returnChar = UCase(str)
    End If
  Else
      returnChar = ""
  End If
End Function