VB读写EXCEL 2000，方法可行必给分

Question

Sub Macro2()
Dim col As String
On Error GoTo exitnow
Set my_excel = New Excel.Application
my_excel.Visible = False
    Set my_work = my_excel.Workbooks.Add
    Set my_sheet = my_work.ActiveSheet
    my_sheet.Range("A1").Select
    my_excel.ActiveCell.FormulaR1C1 = "TO:"
    my_sheet.Range("A2").Select
    my_excel.ActiveCell.FormulaR1C1 = "FM:"
    my_sheet.Range("A3").Select
    my_excel.ActiveCell.FormulaR1C1 = "CC:"
        '3o‥?Aa￥U‥S|3AEAcao
k = 11
j = 0
Dim NoCheck As Long
NoCheck = 0
For x = 1 To vf.Rows - 1
   vf.Row = x
   vf.col = 3
     If vf.Text = "0" Then
       vf.col = 1
       col = Chr(65 + j) & CStr(k + 1) 'Chr(65)?IECA
       my_sheet.Range(col).Select
       my_excel.ActiveCell.FormulaR1C1 = CStr(vf.Text)
       j = j + 1
     End If
   If j > 9 Then
    j = 0
    k = k + 1
   End If
   NoCheck = NoCheck + 1
Next

Answer 1

    my_sheet.Range("H1:I1").Select
    With my_excel.Selection 'EXCEL|X|}3a?﹐Ra
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_sheet.Range("H2:I2").Select
    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_sheet.Range("H3:I3").Select
    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_excel.ActiveCell.FormulaR1C1 = "PAGE:"
    my_sheet.Range("H2:I2").Select
    my_excel.ActiveCell.FormulaR1C1 = "DATE:"
    my_sheet.Range("H1:I1").Select
    my_excel.ActiveCell.FormulaR1C1 = "DOCNO"
    my_sheet.Range("A4:J5").Select
    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_excel.ActiveCell.FormulaR1C1 = "WOAE’u±!apai"
    my_sheet.Range("A6:B6").Select
    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_excel.ActiveCell.FormulaR1C1 = "WO?s?X:"
    my_sheet.Range("C6:J6").Select
    my_sheet.Range("J6").Activate
    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_excel.ActiveCell.FormulaR1C1 = "|b3o‥??e?JWO?s﹐1"
    my_sheet.Range("A7:B9").Select
    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_excel.ActiveCell.FormulaR1C1 = "SN?d3o:"
    my_sheet.Range("I7:J7").Select
    my_sheet.Range("J7").Activate
    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_sheet.Range("C7:G7").Select
    my_sheet.Range("G7").Activate
    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_excel.ActiveCell.FormulaR1C1 = "3324420001~3324429500"
    my_sheet.Range("H7").Select
    my_excel.ActiveCell.FormulaR1C1 = "?A?q(-O):"
    my_sheet.Range("I7:J7").Select
    my_excel.ActiveCell.FormulaR1C1 = " "
    my_sheet.Range("C8:G8").Select
    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_excel.ActiveCell.FormulaR1C1 = "3324521001~3324525000"
    my_sheet.Range("H8").Select
    my_excel.ActiveCell.FormulaR1C1 = "?A?q(-O):"
    my_sheet.Range("I8:J8").Select
    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_excel.ActiveCell.FormulaR1C1 = " "
    my_sheet.Range("C9:G9").Select
    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_sheet.Range("H9").Select
    my_excel.ActiveCell.FormulaR1C1 = "A`-p(-O):"
    my_sheet.Range("I9:J9").Select

Answer 2

    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_excel.ActiveCell.FormulaR1C1 = vf.Rows
    my_sheet.Range("A10:G10").Select
    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_excel.ActiveCell.FormulaR1C1 = "?wAE’uao?K¯E?s﹐1(SN):"
    my_sheet.Range("H10").Select
    my_excel.ActiveCell.FormulaR1C1 = "?A?q(-O):"
    my_sheet.Range("I10:J10").Select
    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_excel.ActiveCell.FormulaR1C1 = vf.Rows - NoCheck
    my_sheet.Range("A10:G10").Select
    With my_excel.Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    my_sheet.Range("A11:G11").Select
    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With    my_excel.Selection.Merge
    my_excel.ActiveCell.FormulaR1C1 = "‥S|3AE’uao?K¯E?s﹐1(SN):"
    my_sheet.Range("H10").Select
    my_excel.Selection.AutoFill Destination:=my_sheet.Range("H10:H11"), Type:=xlFillDefault
    my_sheet.Range("H10:H11").Select
    my_sheet.Range("I11:J11").Select
    With my_excel.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    my_excel.Selection.Merge
    my_excel.ActiveCell.FormulaR1C1 = NoCheck
    my_sheet.Range("A11:G11").Select
    With my_excel.Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    my_sheet.Range("A6:J11").Select
    my_excel.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    my_excel.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With my_excel.Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With my_excel.Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With my_excel.Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With my_excel.Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With my_excel.Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With my_excel.Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With    my_sheet.Range("A1:J55").Select
    my_excel.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    my_excel.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With my_excel.Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With my_excel.Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With my_excel.Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With my_excel.Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    my_sheet.Range("A4:J5").Select
    my_excel.Visible = True
  Set my_sheet = Nothing
  Set my_work = Nothing
  Set my_excel = Nothing
  Exit Sub
exitnow:
MsgBox "error for" & err.
End Sub

Answer 3

Public Function Password_Check(Path As String) As String
Dim db As DAO.Databaseif dir(Path) = "" then
'Return 0 if file does not exist
   Password_Check = "0"
   Exit Function
end ifIf Right(Path, 3) = "mdb" Then
    On Error GoTo errorline
    Set db = OpenDatabase(Path)
    Password_Check = "False"
    db.Close
    Exit Function
ElseIf Right(Path, 3) = "xls" Then
    On Error GoTo errorline
    Set db = OpenDatabase(Path, True, False, "Excel 5.0")
    Password_Check = "False"
    db.Close
    Exit Function
Else
    'Assume it's not a valid file
    'if correct extension is not present
    Password_Check = "0"
    Exit Function
End If
errorline:
    
    Password_Check = "True"
    Exit Function
End Function

Answer 4

就用ole 可以得到 很简单 直接使用

Answer 5

 
 Excel 
 ODBC 
 Standard:
"Driver={Microsoft Excel Driver (*.xls)};DriverId=790;Dbq=C:\MyExcel.xls;DefaultDir=c:\mypath;" 
 OLE DB 
 Standard:"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\MyExcel.xls;Extended Properties=Excel 8.0;HDR=Yes;" 
"HDR=Yes;"

Answer 6

在用vb做程序的时候,它本身的报表并不太好使用,因此应用excel输出数据,是一个好方法,以下是一组操纵excel的函数据,希望能帮助大家.
'excel vba控制函数'检测文件
function checkfile(byval strfile as string) as boolean
dim filexls as object
set filexls = createobject("scripting.filesystemobject")    if isnull(strfile) or strfile = "" then
    checkfile = false
    
    exit function
    end if
   if filexls.fileexists(strfile) = false then
       
        checkfile = false
        set filexls = nothing
        exit function
    else
        
        checkfile = true
        set filexls = nothing
    end if
    
    
end function
'检测工作表
function checksheet(byval strsheet as string, byval strworkbook as string, xlcheckapp as excel.application) as boolean
dim l as integer
dim checkworkbook as excel.workbookif checkfile(strworkbook) and strsheet <> "" and not isnull(strsheet) then
    for l = 1 to xlcheckapp.workbooks.count
    if getpath(xlcheckapp.workbooks(l).path) & xlcheckapp.workbooks(l).name = strworkbook then
    set checkworkbook = xlcheckapp.workbooks(l)
    exit for
    end if
    next l
    
    
    
    set checkworkbook = xlcheckapp.workbooks.open(strworkbook)
    for l = 1 to checkworkbook.worksheets.count
        if checkworkbook.worksheets(l).name = trim(strsheet) then
            checksheet = true
            exit for
        end if
    next lelse
    msgbox "工作表不存在，可能是由文件名或工作表名引起的！"
    checksheet = false
end ifend function'建立工作表
'createmethod:1追加
'createmethod:2覆盖
function createsheet(byval strsheetname as string, byval strworkbook as string, byval createmethod as integer, xlcreateapp as excel.application) as boolean
dim xlcreatesheet as excel.worksheet    
    if checkfile(strworkbook) then
    
        xlcreateapp.workbooks.open (strworkbook)
        
        
        if createmethod = 1 then
        
        if checksheet(strsheetname, strworkbook, xlcreateapp) = false then
        
        set xlcreatesheet = xlcreateapp.worksheets.add
        xlcreatesheet.name = strsheetname
        xlcreateapp.activeworkbook.save
        
        createsheet = true
        set xlcreatesheet = nothing
        else
        'msgbox strsheetname & "工作表已存在！"
        createsheet = false
        set xlcreatesheet = nothing
        end if
        
        
        elseif createmethod = 2 then
        if checksheet(strsheetname, strworkbook, xlcreateapp) = true then
        set xlcreatesheet = xlcreateapp.worksheets(strsheetname)
        xlcreatesheet.cells.select
        xlcreatesheet.cells.delete
        xlcreateapp.activeworkbook.save
        createsheet = true
        set xlcreatesheet = nothing
        else
        'msgbox strsheetname & "工作表不存在！"
        createsheet = false
        set xlcreatesheet = nothing
        end if
        
        end if
        
    end if
    end function
'删除工作表
function deletesheet(byval strsheetname as string, byval strworkbook as string, xldeleteapp as excel.application) as boolean
dim i as integer
dim xldeletesheet as excel.worksheet
    
    if checkfile(strworkbook) then
    
    if checksheet(strsheetname, strworkbook, xldeleteapp) = true then
    
    xldeleteapp.workbooks.open (strworkbook)
    
    if xldeleteapp.worksheets.count = 1 then
        msgbox "工作薄不能全部删除，" & strsheetname & "是最后一个工作表！"
        deletesheet = false
        exit function
    end if
    
    xldeleteapp.worksheets(strsheetname).delete    xldeleteapp.activeworkbook.save
    deletesheet = true
    else
    deletesheet = false
    end if
    
    end if
    
end function'复制工作表
function copysheet(byval strsrcsheetname as string, byval strsrcworkbook as string, byval strtagsheetname as string, byval strtagworkbook as string, xlcopyapp as excel.application) as boolean
dim xlsrcbook as excel.workbook
dim xltagbook as excel.workbook
dim excelsource as excel.worksheet
dim exceltarget as excel.worksheet
dim result as booleanif checkfile(strsrcworkbook) = false or checkfile(strtagworkbook) = false then
set excelsource = nothing
set exceltarget = nothing
set xlsrcbook = nothing
set xltagbook = nothing
    copysheet = false
    exit function
else    set xlsrcbook = xlcopyapp.workbooks.open(strsrcworkbook)
    
    if strsrcworkbook = strtagworkbook then
        if strsrcsheetname = strtagsheetname then
        set excelsource = nothing
        set exceltarget = nothing
        set xlsrcbook = nothing
        set xltagbook = nothing
        copysheet = false
        exit function
        end if
    
        set xltagbook = xlsrcbook
    else
    set xltagbook = xlcopyapp.workbooks.open(strtagworkbook)
    end if
    
    
    
    set excelsource = xlsrcbook.worksheets(strsrcsheetname)
    set exceltarget = xltagbook.worksheets(strtagsheetname)    excelsource.select
    excelsource.cells.copy
    exceltarget.select
    exceltarget.paste
    xlcopyapp.application.cutcopymode = xlcopy
    
    if strsrcworkbook = strtagworkbook then
    xltagbook.save
    xlsrcbook.save
    else
    xltagbook.save
    end if
    
set excelsource = nothing
set exceltarget = nothing
set xlsrcbook = nothing
set xltagbook = nothing
    copysheet = true
end if
end function

Answer 7

'复制工作表
function excelcopysheet(byval strsrcsheetname as string, byval strsrcworkbook as string, byval strtagsheetname as string, byval strtagworkbook as string, xlcopyapp as excel.application) as boolean
dim xlsrcbook as excel.workbook
dim xltagbook as excel.workbook
dim excelsource as excel.worksheet
dim exceltarget as excel.worksheet
dim result as booleanif checkfile(strsrcworkbook) = false or checkfile(strtagworkbook) = false then
set excelsource = nothing
set exceltarget = nothing
set xlsrcbook = nothing
set xltagbook = nothing
    copysheet = false
    exit function
else    set xlsrcbook = xlcopyapp.workbooks.open(strsrcworkbook)
    
    if strsrcworkbook = strtagworkbook then
        if strsrcsheetname = strtagsheetname then
        set excelsource = nothing
        set exceltarget = nothing
        set xlsrcbook = nothing
        set xltagbook = nothing
        copysheet = false
        exit function
        end if
    
        set xltagbook = xlsrcbook
    else
    set xltagbook = xlcopyapp.workbooks.open(strtagworkbook)
    end if
    
    
    
    set excelsource = xlsrcbook.worksheets(strsrcsheetname)
    set exceltarget = xltagbook.worksheets(strtagsheetname)    excelsource.select
    excelsource.copy before
    exceltarget.select
    exceltarget.paste
    xlcopyapp.application.cutcopymode = xlcopy
    
    if strsrcworkbook = strtagworkbook then
    xltagbook.save
    xlsrcbook.save
    else
    xltagbook.save
    end if
    
set excelsource = nothing
set exceltarget = nothing
set xlsrcbook = nothing
set xltagbook = nothing
    copysheet = true
end if
end function'关闭excel应用
function closeexcelapp(xlapp as object)
on error resume next
xlapp.quit
set xlapp = nothing
end function'建立excel应用
function createexcelapp(quitapp as boolean) as object
on error resume next
dim xlobject as object
if checkexcel thenset xlobject = getobject(, "excel.application")
if err.number <> 0 then
    set xlobject = nothing
    set xlobject = createobject("excel.application")
    createexcelapp = xlobject
else
    if quitapp then
    xlobject.quit
    set xlobject = nothing
    set xlobject = createobject("excel.application")
    end if
    createexcelapp = xlobject
end ifend ifend function'检测excel环境
function checkexcel() as boolean
dim xlcheckapp as object
set xlcheckapp = createobject("excel.application")    if xlcheckapp is nothing then
        msgbox "对不起，系统未检测到excel安装，请重新检查excel是否被正确安装！"
        checkexcel = false
        xlcheckapp.quit
        set xlcheckapp = nothing
        exit function
    else
        xlcheckapp.quit
        checkexcel = true
        set xlcheckapp = nothing
    end if
end functionfunction createworkbook(byval strworkbook as string, xlapp as excel.application)
dim xlcreateworkbook as excel.workbookset xlcreateworkbook = xlapp.workbooks.addxlcreateworkbook.saveas (strworkbook)
end function
function getpath(strpath as string) as string
getpath = iif(len(strpath) = 3, strpath, strpath & "\")
end function这上面的函数只不过是一部分,其于的因为专用目的,写不标准,以后也许会整理出来一份标准的函数库的!