Function Split
fonksiyonunun adını değiştir.
Function Splitx yap
modülü aşağıdaki kodlarla değiştir
Option Compare Database
Option Explicit
Private Type Size
cx As Long
cy As Long
End Type
Private Const LF_FACESIZE = 32
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * LF_FACESIZE
End Type
Private Declare Function apiCreateFontIndirect Lib "gdi32" Alias _
"CreateFontIndirectA" (lplogfont As LOGFONT) As Long
Private Declare Function apiSelectObject Lib "gdi32" _
Alias "SelectObject" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function apiGetDC Lib "user32" _
Alias "GetDC" (ByVal hwnd As Long) As Long
Private Declare Function apiReleaseDC Lib "user32" _
Alias "ReleaseDC" (ByVal hwnd As Long, _
ByVal hDC As Long) As Long
Private Declare Function apiDeleteObject Lib "gdi32" _
Alias "DeleteObject" (ByVal hObject As Long) As Long
Private Declare Function apiGetTextExtentPoint32 Lib "gdi32" _
Alias "GetTextExtentPoint32A" _
(ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, _
lpSize As Size) As Long
Declare Function apiCreateIC Lib "gdi32" Alias "CreateICA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Any) As Long
Declare Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" _
(ByVal hDC As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Const SM_CXVSCROLL = 2
Private Const LOGPIXELSX = 88
Function SY(MyForm As String, myctl As String, myfield As Variant, _
col As Integer, RightOrCenter As Integer, Optional Sform As String = "") As Variant
Dim UserControl As Control
Dim UserForm As Form
Dim lngWidth As Long
Dim intSize As Integer
Dim strText As String
Dim lngL As Long
Dim strColumnWidths As String
Dim lngColumnWidth As Long
Dim lngScrollBarWidth As Long
Dim lngOneSpace As Long
Dim lngFudge As Long
Dim arrCols() As String
Dim lngRet As Long
On Error Resume Next
lngFudge = 60
If Len(Sform & vbNullString) > 0 Then
Set UserForm = Forms(MyForm).Controls(Sform).Form
Else
Set UserForm = Forms(MyForm)
End If
Set UserControl = UserForm.Controls.Item(myctl)
With UserControl
If col > Splitx(arrCols(), .ColumnWidths, ";") Then Exit Function
If col = .ColumnCount - 1 Then
lngScrollBarWidth = GetSystemMetrics(SM_CXVSCROLL)
lngScrollBarWidth = lngScrollBarWidth * (1440 / GetTwipsPerPixel())
End If
lngColumnWidth = Nz(Val(arrCols(col)), 1)
lngColumnWidth = lngColumnWidth - (lngScrollBarWidth + lngFudge)
End With
strText = " "
lngWidth = StringToTwips(UserControl, strText)
If lngWidth > 0 Then
lngOneSpace = Nz(lngWidth, 0)
lngWidth = 0
Select Case VarType(myfield)
Case 1 To 6, 7
strText = Str$(myfield)
Case 8
strText = myfield
Case Else
Call MsgBox("Field type must be Numeric, Date or String", vbOKOnly)
End Select
strText = Trim$(strText)
lngWidth = StringToTwips(UserControl, strText)
If lngWidth > 0 Then
Select Case RightOrCenter
Case -1
strText = String(Int((lngColumnWidth - lngWidth) / lngOneSpace), " ") & strText
Case 0
strText = String((Int((lngColumnWidth - lngWidth) / lngOneSpace) / 2), " ") & strText _
& String((Int((lngColumnWidth - lngWidth) / lngOneSpace) / 2), " ")
Case 1
strText = strText
Case Else
End Select
SY = strText
End If
End If
Set UserControl = Nothing
Set UserForm = Nothing
End Function
Function Splitx(ArrayReturn() As String, ByVal StringToSplitx As String, _
SplitxAt As String) As Integer
Dim intInstr As Integer
Dim intCount As Integer
Dim strTemp As String
intCount = -1
intInstr = InStr(StringToSplitx, SplitxAt)
Do While intInstr > 0
intCount = intCount + 1
ReDim Preserve ArrayReturn(0 To intCount)
ArrayReturn(intCount) = Left(StringToSplitx, intInstr - 1)
StringToSplitx = Mid(StringToSplitx, intInstr + 1)
intInstr = InStr(StringToSplitx, SplitxAt)
Loop
If Len(StringToSplitx) > 0 Then
intCount = intCount + 1
ReDim Preserve ArrayReturn(0 To intCount)
ArrayReturn(intCount) = StringToSplitx
End If
Splitx = intCount
End Function
Private Function StringToTwips(ctl As Control, strText As String) As Long
Dim myfont As LOGFONT
Dim stfSize As Size
Dim lngLength As Long
Dim lngRet As Long
Dim hDC As Long
Dim lngscreenXdpi As Long
Dim fontsize As Long
Dim hfont As Long, prevhfont As Long
hDC = apiGetDC(0&)
lngscreenXdpi = GetTwipsPerPixel()
With myfont
.lfFaceName = ctl.FontName & Chr$(0)
fontsize = ctl.fontsize
.lfWeight = ctl.FontWeight
.lfItalic = ctl.FontItalic
.lfUnderline = ctl.FontUnderline
.lfHeight = (fontsize / 72) * -lngscreenXdpi
End With
hfont = apiCreateFontIndirect(myfont)
prevhfont = apiSelectObject(hDC, hfont)
lngLength = Len(strText)
lngRet = apiGetTextExtentPoint32(hDC, strText, lngLength, stfSize)
hfont = apiSelectObject(hDC, prevhfont)
lngRet = apiDeleteObject(hfont)
lngRet = apiReleaseDC(0&, hDC)
StringToTwips = stfSize.cx * (1440 / GetTwipsPerPixel())
End Function
Private Function GetTwipsPerPixel() As Integer
Dim lngIC As Long
lngIC = apiCreateIC("DISPLAY", vbNullString, _
vbNullString, vbNullString)
If lngIC <> 0 Then
GetTwipsPerPixel = GetDeviceCaps(lngIC, LOGPIXELSX)
apiDeleteDC lngIC
Else
GetTwipsPerPixel = 120
End If
End Function