作者 主題: [分享]Excel讀取SQL SERVER 資料 工具鍵menu 按鈕  (閱讀 9026 次)

0 會員 與 1 訪客 正在閱讀本文。

小徒兒

  • 鑽研的研究生
  • *****
  • 文章數: 622
    • 檢視個人資料
代碼: [選擇]
請在進行了/工具/設定引用項目/microsoft DAO 3.6 Object Library  

***在excel加入一個control
Public cmdNewBar As CommandBar
Public WithEvents ctlBtn As CommandBarButton

Private Sub ctlBtn_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)

' Worksheets("Sheet1").Range("A2").Value = 3.14159

'Worksheets("上市").Range("A2").Value = 3.14159

UserForm1.Show
End Sub

Private Sub Workbook_Open()
On Error Resume Next

Application.CommandBars("抓取匯款單").Delete
Set cmdNewBar = Application.CommandBars.Add

cmdNewBar.Name = "抓取匯款單"
With cmdNewBar

        Set ctlBtn = .Controls.Add(msoControlButton)
        
            With ctlBtn
            .Style = msoButtonIconAndCaption
            .BeginGroup = True
            .Caption = "產生匯款單"
            .TooltipText = "產生匯款單"
            .FaceId = 59
            .Tag = "MyCustomTag"
            End With

 .Protection = msoBarNoCustomize
 .Position = msoBarTop
 .Visible = True

  End With


End Sub



****UserForm1

Private Sub UserForm_Activate()
TextBox1.Value = Format(Now, "yyyymmdd")
Calendar1.Value = Now
End Sub

Private Sub UserForm_Click()

End Sub

Public Function MoneyConv(Money As Currency) As String
On Error GoTo Doerr

    Dim CN(9) As String
    Dim CU(15) As String
    Dim Temp As String, strNum As String
    Dim CM As String
    Dim tFirst As String, tEnd As String
    Dim i As Long, j As Long, k As Long
    CN(0) = "零"
    CN(1) = "壹"
    CN(2) = "貳"
    CN(3) = "參"
    CN(4) = "肆"
    CN(5) = "伍"
    CN(6) = "陸"
    CN(7) = "柒"
    CN(8) = "捌"
    CN(9) = "玖"
    
'    CU(0) = "分"
'    CU(1) = "角"
    CU(0) = "圓"
    CU(1) = "拾"
    CU(2) = "佰"
    CU(3) = "仟"
    CU(4) = "萬"
    CU(5) = "拾"
    CU(6) = "佰"
    CU(7) = "仟"
    CU(8) = "億"
    CU(9) = "拾"
    CU(10) = "佰"
    CU(11) = "拾"
    
    If Money = 0 Then
        CM = "零圓整"
        GoTo Complete
    End If
    strNum = Trim(Str(FormatCurrency(Money, 2, vbTrue, vbFalse, vbFalse)))
    If Left(strNum, 1) = "-" Then
        tFirst = "負"
        strNum = Right(strNum, Len(strNum) - 1)
    Else
        
        
        For k = 0 To (8 - Len(strNum)) Step 1
            
         tFirst = "零" + CU(k + Len(strNum)) + "  " + tFirst
        
        Next k
        
        

    
    
    End If
    
    i = InStrRev(strNum, ".")
    If i <> 0 Then
        Temp = Right(strNum, i)
        If Len(strNum) - i = 1 Then Temp = Temp + "0"
        CM = CN(CInt(Left(Right(Temp, 2), 1))) + "角" + CN(CInt(Right(Temp, 1))) + "分"
        tEnd = ""
        strNum = Left(strNum, i - 1)
    Else
        tEnd = ""
    End If
    
    i = 0
    
    'For j = 9 To 1 Step -1
    For j = Len(strNum) To 1 Step -1
        k = CInt(Right(Left(strNum, j), 1))
        If k = 0 Then
           ' If i <> 0 And i <> 4 And i <> 8 Then
            '    CM = CN(k) + CM
           ' Else
                CM = CN(k) + CU(i) + "  " + CM
            'End If
        Else
            CM = CN(k) + CU(i) + "  " + CM
        End If
'        CM = CN(k) + CU(i) + CM
        i = i + 1
    Next j
    
    
    
    
    
    
    
    
    CM = tFirst + CM + tEnd
    CM = Replace(CM, "零零", "零")
    CM = Replace(CM, "零零", "零")
    CM = Replace(CM, "億零万零圓", "億圓")
    CM = Replace(CM, "億零万", "億零")
    CM = Replace(CM, "万零圓", "万圓")
    'CM = Replace(CM, "零億", "億")
    'CM = Replace(CM, "零万", "万")
    'CM = Replace(CM, "零圓", "圓")
    CM = Replace(CM, "零零", "零")
    CM = Replace(CM, "零零", "零")        '重复替換一次

Complete:
    Gerr = 0              '操作成功,無錯誤發生
    MoneyConv = CM
    Exit Function
Doerr:
    Gerr = -1              '未知錯誤
Errexit:
    MoneyConv = ""
End Function


***透過使用windows api 偵測keypress keycode狀態

Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer

'   Constants for the keys of interest
    Const VK_SHIFT As Integer = &H10
    Const VK_CONTROL As Integer = &H11
    Const VK_MENU As Integer = &H12 'Alt key


Sub DisplayKeyStatus()
    Dim TabChar As String * 1
    Dim CRChar As String * 1
    Dim Shift As Boolean, Control As Boolean, Alt As Boolean
    Dim Msg As String
    
    TabChar = Chr(9)
    CRChar = Chr(13)

'   Use API calls to determine which keys are pressed
    If GetKeyState(VK_SHIFT) < 0 Then Shift = True Else Shift = False
    If GetKeyState(VK_CONTROL) < 0 Then Control = True Else Control = False
    If GetKeyState(VK_MENU) < 0 Then Alt = True Else Alt = False

'   Build the message
    Msg = "Shift:" & TabChar & Shift & CRChar
    Msg = Msg & "Control:" & TabChar & Control & CRChar
    Msg = Msg & "Alt:" & TabChar & Alt & CRChar
    
'   Display message box
    MsgBox Msg, vbInformation, "Key Status"
End Sub


****透過使用windows api 得出windows directory
=WindowsDir()

Option Explicit
Declare Function GetWindowsDirectoryA Lib "kernel32" _
  (ByVal lpBuffer As String, ByVal nSize As Long) As Long


Sub ShowWindowsDir()
    Dim WinPath As String * 255
    Dim WinDir As String
    WinPath = Space(255)
    WinDir = Left(WinPath, GetWindowsDirectoryA _
      (WinPath, Len(WinPath)))
    MsgBox WinDir, vbInformation, "Windows Directory"
End Sub


Function WindowsDir() As String
'   Returns the Windows directory
    Dim WinPath As String * 255
    WinPath = Space(255)
    WindowsDir = Left(WinPath, GetWindowsDirectoryA _
       (WinPath, Len(WinPath)))
End Function



請在進行了 microsoft DAO 3.6 Object Library 設定引用項目
[code]
Sub F_Sample051()
    'Microsoft DAO 3.6 Object Library ?#93;定引用項目
    Dim myWsp  As DAO.Workspace
    Dim myCon  As DAO.Connection
    Dim myRst  As DAO.Recordset
    Dim myCnc1 As String
    Dim myCnc2 As String
    Dim myCnc3 As String
    Dim myCmd  As String
    Dim i      As Long
    myCnc1 = "ODBC;"
    myCnc2 = "Driver=SQL Server;"
    '指定要連接的伺服器
    myCnc3 = "SERVER=127.0.0.1;UID=sa;PWD=test;DATABASE=Northwind;FILEDSN=C:"
    '以SQL敘述來指定要取得的表單
    myCmd = "SELECT EmployeeID FROM Employees"
    Set myWsp = CreateWorkspace("myWsp", "myName", "", dbUseODBC)
    Workspaces.Append myWsp                 '工作表的新增
    Set myCon = myWsp.OpenConnection( _
        Name:="myConnection", _
        Options:=dbDriverNoPrompt, _
        Connect:=myCnc1 & myCnc2 & myCnc3)
    Set myRst = myCon.OpenRecordset(myCmd)
    Worksheets.Add
    With myRst
        '欄名
        For i = 1 To .Fields.Count
            Cells(1, i).Value = .Fields(i - 1).Name
        Next
        '記錄
        Range("A2").CopyFromRecordset myRst
        .Close
    End With
    myCon.Close
    myWsp.Close
    Set myRst = Nothing                 '物件的釋放
    Set myCon = Nothing
    Set myWsp = Nothing
End Sub





代碼: [選擇]

Set cmdNewBar = Application.CommandBars.Add("my bar")


With cmdNewBar
    Set ctlBtn = .Controls.Add
    With ctlBtn
            .Style = msoButtonIconAndCaption
            .BeginGroup = True
            .Caption = "&Button"
            .TooltipText = "ToolTip"
            .FaceId = 59
    End With
    
    .Protection = msoBarNoCustomize
    .Position = msoBarTop
    .Visible = True

End With


代碼: [選擇]


Dim Btn As CommandBarControl
    On Error Resume Next
    Application.CommandBars(3).Controls(Application.CommandBars.FindControl(ID:=2031).Caption).Delete
    Set Mybar = Application.CommandBars(3).Controls.Add
    With Mybar
        .FaceId = 629
        .OnAction = "IntComment"
        .Caption = Application.CommandBars.FindControl(ID:=2031).Caption
        .Enabled = True
    End With
    ResetCmt
    Err = 0



 Worksheets("Sheet1").Range("A2").Value = 3.14159


***取代空白


Worksheets("ackind").Columns("B").Replace _
What:=" ", Replacement:="", _
    SearchOrder:=xlByColumns, MatchCase:=True


Worksheets("ackind").Columns("B").Replace _
What:=" ", Replacement:="", _
    SearchOrder:=xlByColumns, MatchCase:=True

***依據某欄 算出另一欄資料

Sub Macro1()
Dim columnOri     As String
Dim columnTo As String
For k = 1 To 1055 Step 1
    columnOri = "E" & k
    columnTo = "F" & k
    Range(columnTo).Value = Range(columnOri).Value & "0000"
Next k
End Sub


***

多個回傳值-----------------------------------------------------------------------------------------------


代碼: [選擇]

Private Sub Calendar1_Click()
TextBox1.Value = Format(Calendar1.Value, "yyyymmdd")
End Sub

Private Sub CommandButton1_Click()
 Dim myWsp  As DAO.Workspace
    Dim myCon  As DAO.Connection
    Dim myRst  As DAO.Recordset
    Dim myCnc1 As String
    Dim myCnc2 As String
    Dim myCnc3 As String
    Dim myCmd  As String
    Dim i      As Long
    myCnc1 = "ODBC;"
    myCnc2 = "Driver=SQL Server;"
    '指定要連接的伺服器
    myCnc3 = "SERVER=172.0.0.1;UID=test;PWD=test;DATABASE=SEMS;FILEDSN=C:"
    '以SQL敘述來指定要取得的表單
    myCmd = "select case when Buy - Sale<=0 then 0 else Buy-Sale end from (select cast(sum(AmtPrice) as float) as Buy from TraderTrans where ADate = '" + TextBox1.Value + "' and BS = 0) a, (select cast(sum(AmtPrice) as float) as Sale from TraderTrans where ADate = '" + TextBox1.Value + "' and BS = 1) b"
     'myCmd = "select case when 1=2 then 0 else 1 end"
    'myCmd = "select cast(sum(AmtPrice) as float) as Buy from TraderTrans"
    Set myWsp = CreateWorkspace("myWsp", "myName", "", dbUseODBC)
    Workspaces.Append myWsp                 '工作表的新增
    Set myCon = myWsp.OpenConnection( _
        Name:="myConnection", _
        Options:=dbDriverNoPrompt, _
        Connect:=myCnc1 & myCnc2 & myCnc3)
    Set myRst = myCon.OpenRecordset(myCmd)
    'Worksheets.Add
    With myRst
        '欄名
        
        If (myRst.EOF = True) Then
        
        Range("A5").Value = "0"
        Range("B5").Value = "0"
        Label3.Caption = "0"
        
        Else
 
          
    
    
    
        'Range("B5").Value = myRst.Fields("Date2")
        'Range("B6").Value = myRst.Fields("Market")
        Range("A5").Value = myRst.Fields("count_")
        Range("B5").Value = CCur(myRst.Fields("Amt"))
        Label3.Caption = CCur(myRst.Fields("Amt"))
        Range("A5").Select
        
        'Range("B9").Value = myRst.Fields("Tax")
        End If
        
        
        .Close
    End With
    
    myCmd = "SELECT '" + TextBox1.Value + "' Date1,dbo.fn_getworkday('" + TextBox1.Value + "', 1) Date2,isnull(t.Market,0) Market,isnull(Sum(ACount) ,0) count_,isnull(SUM(SAmt),0) Amt,isnull(ROUND(SUM(SAmt) * 0.003,0, 1),0) Tax FROM (SELECT stk.Market_ Market, ts.StockId, ts.SAmt, Count(*) ACount FROM TraderStock ts INNER Join Trader ON ts .TraderId = Trader.TraderId INNER JOIN TraderGroup ON Trader.GroupId = TraderGroup.GroupId LEFT JOIN dbo.fn_stock('" + TextBox1.Value + "') stk ON stk.stockid_ = ts.StockId Left Join TraderTrans c On stk.stockid_ = c.StockId WHERE     TraderGroup.GroupId = '" + GroupID + "' and  ts.ADate = '" + TextBox1.Value + "' and c.ADate = '" + TextBox1.Value + "' And c.BS = 1 AND ts.SAmt > 0 AND stk.Market_='O' Group by ts.StockId, stk.Market_, ts.SAmt) t GROUP BY Market"
    
    'SELECT '20060208' Date1,dbo.fn_getworkday('20060208', 1) Date2,isnull(t.Market,0) Market,isnull(Sum(ACount) ,0) count_,isnull(SUM(SAmt),0) Amt,isnull(ROUND(SUM(SAmt) * 0.003,0, 1),0) Tax FROM (SELECT stk.Market_ Market, ts.StockId, ts.SAmt, Count(*) ACount FROM TraderStock ts INNER Join Trader ON ts .TraderId = Trader.TraderId INNER JOIN TraderGroup ON Trader.GroupId = TraderGroup.GroupId LEFT JOIN dbo.fn_stock('20060208') stk ON stk.stockid_ = ts.StockId Left Join TraderTrans c On stk.stockid_ = c.StockId WHERE     TraderGroup.GroupId = 'G88' and  ts.ADate = '20060208' and c.ADate = '20060208' And c.BS = 1 AND ts.SAmt > 0 AND stk.Market_='O' Group by ts.StockId, stk.Market_, ts.SAmt) t GROUP BY Market

    
    'myCmd = "SELECT '" + TextBox1.Value + "' Date1, dbo.fn_getworkday('" + TextBox1.Value + "', 1) Date2, isnull(Market,0) Market, isnull(COUNT(*) ,0) count_, isnull(SUM(SAmt),0) Amt, isnull(ROUND(SUM(SAmt) * 0.003, 0, 1),0) Tax FROM (SELECT ts.StockId, ts.SAmt, Count(*) ACount FROM TraderStock ts LEFT JOIN dbo.fn_stock('" + TextBox1.Value + "') stk ON stk.stockid_ = ts.StockId Left Join TraderTrans c On stk.stockid_ = c.StockId WHERE ts.ADate = '" + TextBox1.Value + "' and c.ADate = '" + TextBox1.Value + "' And c.BS = 1 AND ts.SAmt > 0 AND stk.Market_='O' Group by ts.StockId, stk.Market_, ts.SAmt) t GROUP BY Market"
    'myCmd = "SELECT '" + TextBox1.Value + "' Date1, dbo.fn_getworkday('" + TextBox1.Value + "', 1) Date2,   isnull(Market,0) Market, isnull(COUNT(*) ,0) count_, isnull(SUM(SAmt),0) Amt, isnull(ROUND(SUM(SAmt) * 0.003, 0, 1),0) Tax FROM (SELECT CASE WHEN market_ = 'U' THEN 'O' ELSE market_ END Market, SAmt FROM TraderStock ts INNER Join Trader ON ts .TraderId = Trader.TraderId INNER JOIN TraderGroup ON Trader.GroupId = TraderGroup.GroupId LEFT JOIN dbo.fn_stock('" + TextBox1.Value + "') stk ON stk.stockid_ = ts.StockId WHERE TraderGroup.GroupId = '" + GroupID + "' AND ADate = '" + TextBox1.Value + "' AND SAmt > 0 AND Market_='O') t GROUP BY Market"
    
    Set myRst = myCon.OpenRecordset(myCmd)
    
    With myRst
        '欄名
        
        If (myRst.EOF = True) Then
        Range("D5").Value = "0"
        Range("E5").Value = "0"
        Label5.Caption = "0"
        
        Else
        Range("D5").Value = myRst.Fields("count_")
        Range("E5").Value = CCur(myRst.Fields("Amt"))
        
        
        
        
        Label5.Caption = CCur(myRst.Fields("Amt"))
        
        End If
        
    End With
        
        
        myCmd = "SELECT '" + TextBox1.Value + "' Date1, dbo.fn_getworkday('" + TextBox1.Value + "', 1) Date2"
        Set myRst = myCon.OpenRecordset(myCmd)
    
        Date2 = Right(Trim(myRst.Fields("Date2")), 2)
        strDay1 = Left(Date2, 1)
        strDay2 = Right(Date2, 1)
        
        Date1 = Right(Trim(myRst.Fields("Date1")), 2)
        strDay3 = Left(Date1, 1)
        strDay4 = Right(Date1, 1)
                
        
        
    Range("C12").Value = "          " + Left(MoneyConv(Range("B12").Value), 16) + "  " + Right(MoneyConv(Range("B12").Value), 16)
    
   '  Range("C12").Value = MoneyConv(Range("B12").Value)
    
    Range("B1").Value = "              " + strYear1 + "   " + strYear2 + "  " + strMonth1 + "  " + strMonth2 + "  " + strDay3 + "  " + strDay4 + "   5  1  8  T"
    
    Range("B13").Value = "        " + strYear1 + strYear2 + "      " + strMonth1 + strMonth2 + "     " + strDay1
    Range("C13").Value = strDay2
    Range("C13").HorizontalAlignment = xlLeft
        

        With ActiveCell.Characters(Start:=1, Length:=1).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    With ActiveCell.Characters(Start:=2, Length:=1).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    With ActiveCell.Characters(Start:=3, Length:=3).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    With ActiveCell.Characters(Start:=6, Length:=1).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    With ActiveCell.Characters(Start:=7, Length:=3).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    With ActiveCell.Characters(Start:=10, Length:=1).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    With ActiveCell.Characters(Start:=11, Length:=3).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    With ActiveCell.Characters(Start:=14, Length:=1).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    With ActiveCell.Characters(Start:=15, Length:=3).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    With ActiveCell.Characters(Start:=18, Length:=1).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    With ActiveCell.Characters(Start:=19, Length:=3).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    With ActiveCell.Characters(Start:=22, Length:=1).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    With ActiveCell.Characters(Start:=23, Length:=3).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    With ActiveCell.Characters(Start:=26, Length:=1).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    With ActiveCell.Characters(Start:=27, Length:=3).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    With ActiveCell.Characters(Start:=30, Length:=1).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    With ActiveCell.Characters(Start:=31, Length:=3).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    With ActiveCell.Characters(Start:=34, Length:=1).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    With ActiveCell.Characters(Start:=35, Length:=2).Font
        .Name = "新細明體"
        .FontStyle = "標準"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
        
          
      
        Range("D1").Value = "   " & (CInt(Left(TextBox1.Value, 4)) - 1911) & "    " & CInt(Right(Left(TextBox1.Value, 6), 2)) & "   " & (CInt(Right(Left(TextBox1.Value, 8), 2)) + 2)
        .Close
    End With
    myCon.Close
    myWsp.Close
    Set myRst = Nothing                 '物件的釋放
    Set myCon = Nothing
    Set myWsp = Nothing
End Sub

Private Sub Label2_Click()

End Sub

Private Sub Label3_Click()

End Sub

Private Sub UserForm_Activate()
TextBox1.Value = Format(Now, "yyyymmdd")
Calendar1.Value = Now
End Sub

Private Sub UserForm_Click()

End Sub

Public Function MoneyConv(Money As Currency) As String
On Error GoTo Doerr

    Dim CN(9) As String
    Dim CU(15) As String
    Dim Temp As String, strNum As String
    Dim CM As String
    Dim tFirst As String, tEnd As String
    Dim i As Long, j As Long, k As Long
    CN(0) = "零"
    CN(1) = "壹"
    CN(2) = "貳"
    CN(3) = "參"
    CN(4) = "肆"
    CN(5) = "伍"
    CN(6) = "陸"
    CN(7) = "柒"
    CN(8) = "捌"
    CN(9) = "玖"
    
'    CU(0) = "分"
'    CU(1) = "角"
    CU(0) = "圓"
    CU(1) = "拾"
    CU(2) = "佰"
    CU(3) = "仟"
    CU(4) = "萬"
    CU(5) = "拾"
    CU(6) = "佰"
    CU(7) = "仟"
    CU(8) = "億"
    CU(9) = "拾"
    CU(10) = "佰"
    CU(11) = "拾"
    
    If Money = 0 Then
        CM = "零圓整"
        GoTo Complete
    End If
    strNum = Trim(Str(FormatCurrency(Money, 2, vbTrue, vbFalse, vbFalse)))
    If Left(strNum, 1) = "-" Then
        tFirst = "負"
        strNum = Right(strNum, Len(strNum) - 1)
    Else
        
        
        For k = 0 To (8 - Len(strNum)) Step 1
            
         tFirst = "零" + CU(k + Len(strNum)) + "  " + tFirst
        
        Next k
        
        

    
    
    End If
    
    i = InStrRev(strNum, ".")
    If i <> 0 Then
        Temp = Right(strNum, i)
        If Len(strNum) - i = 1 Then Temp = Temp + "0"
        CM = CN(CInt(Left(Right(Temp, 2), 1))) + "角" + CN(CInt(Right(Temp, 1))) + "分"
        tEnd = ""
        strNum = Left(strNum, i - 1)
    Else
        tEnd = ""
    End If
    
    i = 0
    
    'For j = 9 To 1 Step -1
    For j = Len(strNum) To 1 Step -1
        k = CInt(Right(Left(strNum, j), 1))
        If k = 0 Then
           ' If i <> 0 And i <> 4 And i <> 8 Then
            '    CM = CN(k) + CM
           ' Else
                CM = CN(k) + CU(i) + "  " + CM
            'End If
        Else
            CM = CN(k) + CU(i) + "  " + CM
        End If
'        CM = CN(k) + CU(i) + CM
        i = i + 1
    Next j
    
    
    
    
    
    
    
    
    CM = tFirst + CM + tEnd
    CM = Replace(CM, "零零", "零")
    CM = Replace(CM, "零零", "零")
    CM = Replace(CM, "億零万零圓", "億圓")
    CM = Replace(CM, "億零万", "億零")
    CM = Replace(CM, "万零圓", "万圓")
    'CM = Replace(CM, "零億", "億")
    'CM = Replace(CM, "零万", "万")
    'CM = Replace(CM, "零圓", "圓")
    CM = Replace(CM, "零零", "零")
    CM = Replace(CM, "零零", "零")        '重复替換一次

Complete:
    Gerr = 0              '操作成功,無錯誤發生
    MoneyConv = CM
    Exit Function
Doerr:
    Gerr = -1              '未知錯誤
Errexit:
    MoneyConv = ""
End Function






http://solosoho.com/excelvba/getfile.html

傳入兩個參數
代碼: [選擇]
Function Commission2(Sales, Years) As Single
'    Calculates sales commissions based on
'    years in service
     Const Tier1 = 0.08
     Const Tier2 = 0.105
     Const Tier3 = 0.12
     Const Tier4 = 0.14
     Select Case Sales
        Case 0 To 9999.99: Commission2 = Sales * Tier1
        Case 10000 To 19999.99: Commission2 = Sales * Tier2
        Case 20000 To 39999.99: Commission2 = Sales * Tier3
        Case Is >= 40000: Commission2 = Sales * Tier4
     End Select
     Commission2 = Commission2 + (Commission2 * Years / 100)
End Function


Sub CalcComm()
    Dim Sales As Double
    Dim Message As String
    Dim Ans As Integer
    
'   Prompt for sales amount
    Sales = Val(InputBox("Enter Sales:", _
     "Sales Commission Calculator"))

'   Build the message
    Message = "Sales Amount:" & vbTab & Format(Sales, "$#,##0")
    Message = Message & vbCrLf & "Commission:" & vbTab
    Message = Message & Format(Commission(Sales), "$#,##0")
    Message = Message & vbCrLf & vbCrLf & "Another?"

'   Display the result and prompt for another
    Ans = MsgBox(Message, vbYesNo, "Sales Commission Calculator")
    If Ans = vbYes Then CalcComm
End Sub



***傳入一個array,當作參數
Function SumArrary(List) As Double

   Dim Item As Variant
   SumArray=0
   For Each Item In List
   If WorkSheetFunction.IsNumber(Item) Then _

      SumArrary = SumArrary + Item
   Next Item
End Function


帶有不定數量參數的函數
代碼: [選擇]
Function MySum(ParamArray args() As Variant) As Variant
' Emulates Excel's SUM function
 
' Variable declarations
 Dim i As Variant
 Dim TempRange As Range, cell As Range
 Dim ECode As String
 MySum = 0

' Process each argument
 For i = LBound(args) To UBound(args)
     MySum = MySum + args(i)

   End Select
  End If
 Next i
End Function

代碼: [選擇]
Function MySum(ParamArray arglist() As Variant) As Variant
  For Each arg In arglist

        SimpleSum =SimpleSum + arg
  next arg

End function



呼叫程序
代碼: [選擇]
Sub Main()
    dim SubToCall As String
    Select Case WeekDay(Now)
         Case 1: SubToCall = "WeekEnd"
         Case 7: SubToCall = "WeekEnd"
         Case Else: SubToCall = "Daily"

     End Select
          Application.Run SubToCall

End Sub

Sub WeekEnd()
     Msgbox "Today is a weekend"

End Sub

Sub Daily()
     Msgbox "Today is not a weekend"
End Sub








[/code]
« 上次編輯: 2008-06-11 15:21 由 小徒兒 »

洋蔥叔叔

  • 區域板主
  • 鑽研的研究生
  • *****
  • 文章數: 830
    • 檢視個人資料
    • 洋蔥叔叔的隨意漫談電腦、網路、.NET、軟體本地化、雜七雜八
[分享]Excel讀取SQL SERVER 資料
« 回覆 #1 於: 2005-12-27 14:15 »
直接在 Excel 中用 [資料] - [匯入外部資料] ?

hoyo

  • 榮譽博士
  • 俺是博士!
  • *****
  • 文章數: 4051
  • 性別: 男
  • 有需要的時候,學習就不會分階段。
    • 檢視個人資料
    • 樂咖黑電腦學習網
[分享]Excel讀取SQL SERVER 資料
« 回覆 #2 於: 2005-12-27 15:05 »
小徒兒師傅,可否幫我了解一下,VBA 是否可使用 winsock 功能?

還是說 vb 有的功能 VBA 【全部】都有
受人與魚,不如授人與漁
上海自來水來自海上;倫敦好奇人奇好敦倫

小徒兒

  • 鑽研的研究生
  • *****
  • 文章數: 622
    • 檢視個人資料
[分享]Excel讀取SQL SERVER 資料
« 回覆 #3 於: 2005-12-27 17:02 »
excel / 工具/巨集/vb編譯器

插入/自訂表單

檢視/工具箱

請在工具箱上按左鍵/選新增控制項 選取 Mxxxxx WinSock Control 6.0


-------------------------
也可直接呼叫"WSOCK32.DLL" 的api

相關程式碼
上google 查
 "Declare Function WSACleanup Lib"

hoyo

  • 榮譽博士
  • 俺是博士!
  • *****
  • 文章數: 4051
  • 性別: 男
  • 有需要的時候,學習就不會分階段。
    • 檢視個人資料
    • 樂咖黑電腦學習網
[分享]Excel讀取SQL SERVER 資料
« 回覆 #4 於: 2005-12-27 17:13 »
感謝小徒兒師傅的指導,懶人在此向你道謝 ^^
受人與魚,不如授人與漁
上海自來水來自海上;倫敦好奇人奇好敦倫

小徒兒

  • 鑽研的研究生
  • *****
  • 文章數: 622
    • 檢視個人資料
[分享]Excel get chart name and reset
« 回覆 #5 於: 2008-05-22 13:52 »
Sub GetChartNames()
   Dim chtObject As ChartObject
   Dim i As Integer
   Dim thischart As ChartObject
   
   i = 1
   For Each chtObject In ActiveSheet.ChartObjects
       
     i = i + 1
   'Cells(i, 20) = chtObject.Name & "  " & CStr(chtObject.Top) & "  " & CStr(chtObject.Left)
     
       
     
   Next
   
   
   ActiveSheet.ChartObjects("Chart 60").Select
   
   Set thischart = ActiveSheet.ChartObjects("Chart OverTime")
   MsgBox thischart.Name
   'thischart.Name = "Chart OverTime"
   
End Sub