Showing posts with label VB. Show all posts
Showing posts with label VB. Show all posts

Friday, September 5, 2025

CopyFromSelectedWorkbookToThisWorkbook

 Sub CopyFromSelectedWorkbookToThisWorkbook()

    Dim sourceWB As Workbook

    Dim targetWB As Workbook

    Dim sourceWS As Worksheet

    Dim targetWS As Worksheet

    Dim copyRange As Range

    Dim lastRow As Long, lastCol As Long

    Dim filePath As Variant


    ' Set reference to the target workbook and Sheet1

    Set targetWB = ThisWorkbook

    'Set targetWS = targetWB.ActiveSheet

    Set targetWS = targetWB.Sheets("Sheet1")

    targetWS.cells.clear

    ' Prompt user to select the source workbook (.xls or .xlsx)

    filePath = Application.GetOpenFilename("Excel Files (*.xls; *.xlsx), *.xls; *.xlsx", , "Select Source Workbook")


    ' Exit if user cancels

    If filePath = False Then

        MsgBox "No file selected.", vbExclamation

        Exit Sub

    End If


    ' Open the source workbook

    Set sourceWB = Workbooks.Open(filePath)

    Set sourceWS = sourceWB.ActiveSheet


    ' Find the last used row and column in source sheet

    lastRow = sourceWS.Cells(sourceWS.Rows.Count, 2).End(xlUp).Row

    lastCol = sourceWS.Cells(lastRow, sourceWS.Columns.Count).End(xlToLeft).Column


    ' Define the range to copy

    Set copyRange = sourceWS.Range(sourceWS.Cells(1, 1), sourceWS.Cells(lastRow, lastCol))



    ' Paste the copied range into Sheet1

    copyRange.Copy

    targetWS.Range("A1").PasteSpecial Paste:=xlPasteAll

    ' Optional: Close the source workbook without saving

    sourceWB.Close SaveChanges:=False


    ' Clear clipboard

    Application.CutCopyMode = False


End Sub

Thursday, September 4, 2025

ExportToCSV

 Sub ExportToCSV()

    Dim ws As Worksheet

    Dim exportRange As Range

    Dim lastRow As Long

    Dim filePath As String


    ' Set the worksheet (change Sheet10 to your actual sheet name if needed)

    Set ws = ThisWorkbook.ActiveSheet


    ' Find the last row with data in column A

    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row


    ' Define the range to export (A1 to D[lastRow])

    Set exportRange = ws.Range("A1:D" & lastRow)


    ' Set the file path (you can change this to your desired location)

    filePath = Application.ThisWorkbook.Path & "\ExportedData.csv"


    ' Export the range to CSV

    Open filePath For Output As #1

    Dim r As Range, cell As Range


    For Each r In exportRange.Rows

        Dim line As String

        line = ""

        For Each cell In r.Cells

            line = line & cell.Text & vbTab

        Next cell

        ' Remove trailing tab

        If Len(line) > 0 Then line = Left(line, Len(line) - 1)

        Print #1, line

    Next r

    Close #1



    MsgBox "Data exported to CSV successfully!" & vbCrLf & filePath, vbInformation

End Sub

Thursday, March 13, 2025

VBA select area to export to picture and set name same sheet name

 Sub ExportAllSheets()

    Dim oWs As Worksheet

    Dim oRng As Range

    Dim oChrtO As ChartObject

    Dim lWidth As Long, lHeight As Long

    Dim sFilePath As String

    

    sFilePath = "d:\"

    

    For Each oWs In ActiveWorkbook.Worksheets

        ActiveWindow.Zoom = 100

        Set oRng = oWs.Range("B2:n30")

        

        oRng.CopyPicture xlScreen, xlPicture

        lWidth = oRng.Width

        lHeight = oRng.Height

        

        Set oChrtO = oWs.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)

        

        oChrtO.Activate

        With oChrtO.chart

            .Paste

            .Export Filename:=sFilePath & oWs.Name & ".jpg", Filtername:="JPG"

        End With

        

        oChrtO.Delete

    Next oWs

End Sub


Monday, October 21, 2024

ACCESS VBA openform after closeform code continue

Sub OpenFormAndWait()

    ' Open the form in dialog mode

    DoCmd.OpenForm "YourFormName", WindowMode:=acDialog

    

    ' Code here will execute after the form is closed

    MsgBox "The form has been closed. Continuing with the code..."

End Sub


from copilot help

Wednesday, October 9, 2024

VBA Send JSON to HTTP POST PHP

 VBA

Sub SendJsonData()

    On Error GoTo ErrorHandler


    ' Create an object for ServerXMLHTTP

    Dim xmlhttp As Object

    Set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")


    ' Define the URL where the data will be sent

    Dim url As String

    url = "https://192.168.0.88/xampp/API/P1.php" ' Modify the URL accordingly


    ' Create the JSON Payload

    Dim jsonData As String

    Set ws = ThisWorkbook.Sheets("Sheet1")

    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    

   'jsonData = "{""name"":""John"",""value"":30}"

    For i = 2 To lastRow

        jsonData = "{""name"":""" & ws.Cells(i, 1).Value & """, ""value"":""" & ws.Cells(i, 2).Value & """}"

        If i < lastRow Then

            jsonData = jsonData & ","

        End If

    Next i

    


    ' Set the Method and open the connection

    xmlhttp.Open "POST", url, False


    ' Bypass SSL Certificates validation (for self-signed certificates only)

    xmlhttp.setOption 2, 13056 ' Ignore SSL certificate errors


    ' Set HTTP Header to indicate that the data is JSON

    xmlhttp.setRequestHeader "Content-Type", "application/json"


    ' Send the JSON data

    xmlhttp.send jsonData


    ' Check the status of the request

    If xmlhttp.Status = 200 Then

        MsgBox "Data sent successfully: " & xmlhttp.responseText

    Else

        MsgBox "Error: " & xmlhttp.Status & " - " & xmlhttp.statusText

    End If


    ' Close the connection

    Set xmlhttp = Nothing

    Exit Sub


ErrorHandler:

    MsgBox "Error occurred: " & Err.Description

End Sub

PHP

<?php

// ตั้งค่า Header เพื่อระบุว่าคำตอบเป็น JSON และอนุญาตการเชื่อมต่อ CORS (ถ้าจำเป็น)

header("Content-Type: application/json");

header("Access-Control-Allow-Origin: *");


// ข้อมูลการเชื่อมต่อฐานข้อมูล MySQL

$servername = "192.168.0.88"; // หรือ IP ของเซิร์ฟเวอร์ฐานข้อมูล

$username = "prapop";        // ชื่อผู้ใช้ MySQL (เปลี่ยนตามจริง)

$password = "";            // รหัสผ่านของ MySQL (เปลี่ยนตามจริง)

$dbname = "test";    // ชื่อฐานข้อมูล


// สร้างการเชื่อมต่อฐานข้อมูล

$conn = new mysqli($servername, $username, $password, $dbname);


// ตรวจสอบการเชื่อมต่อ

if ($conn->connect_error) {

    die(json_encode([

        'status' => 'error',

        'message' => 'Connection failed: ' . $conn->connect_error

    ]));

}


// ตรวจสอบว่าคำขอเป็น POST หรือไม่

if ($_SERVER['REQUEST_METHOD'] == 'POST') {

    // รับข้อมูล JSON ที่ส่งมา

    $json = file_get_contents('php://input');

    

    // แปลง JSON ให้เป็น Array หรือ Object

    $data = json_decode($json, true);


    // ตรวจสอบว่าการแปลงสำเร็จหรือไม่

    if ($data === null) {

        // กรณีที่ข้อมูล JSON ไม่ถูกต้อง

        echo json_encode([

            'status' => 'error',

            'message' => 'Invalid JSON'

        ]);

    } else {

        // เข้าถึงข้อมูลที่ส่งมา

        $name = $data['name'];

        $value = $data['value'];


        // เตรียมคำสั่ง SQL สำหรับบันทึกข้อมูล

        // ตรวจสอบว่า prepare สำเร็จหรือไม่

        $stmt = $conn->prepare("INSERT INTO T1 (name, value) VALUES (?, ?)");


        if ($stmt === false) {

            die(json_encode([

                'status' => 'error',

                'message' => 'Prepare failed: ' . $conn->error

            ]));

        }


        $stmt->bind_param("si", $name, $value); // ผูกตัวแปรเพื่อป้องกัน SQL Injection


        // ตรวจสอบการบันทึกข้อมูล

        if ($stmt->execute()) {

            // สำเร็จ

            echo json_encode([

                'status' => 'success',

                'message' => 'Data inserted successfully',

                'name' => $name,

                'value' => $value

            ]);

        } else {

            // เกิดข้อผิดพลาด

            echo json_encode([

                'status' => 'error',

                'message' => 'Error inserting data: ' . $stmt->error

            ]);

        }


        // ปิด statement

        $stmt->close();

    }

} else {

    // กรณีที่ไม่ใช่คำขอแบบ POST

    echo json_encode([

        'status' => 'error',

        'message' => 'Only POST requests are allowed'

    ]);

}


// ปิดการเชื่อมต่อฐานข้อมูล

$conn->close();

?>


MYSQL

CREATE TABLE T1 (

    id INT AUTO_INCREMENT PRIMARY KEY,

    name VARCHAR(255) NOT NULL,

    value VARCHAR(255) NOT NULL

);


Monday, June 10, 2024

example: select folder to open each file and find data --> save to another file

Sub find_error()

    Dim oFSO As Object

    Dim oFolder As Object

    Dim oFile As Object

    Dim FldrPicker As FileDialog

    Dim myFolder As String

    Dim File_Open As Workbook

    

    'Have User Select Folder to Save to With Dialog Box

    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    

    With FldrPicker

        .Title = "Select A Target Folder"

        .AllowMultiSelect = False

        If .Show <> -1 Then Exit Sub 'Check If user clicked cancel button

            myFolder = .SelectedItems(1) & "\"

    End With

        

    Set oFSO = CreateObject("Scripting.FileSystemObject")

    Set oFolder = oFSO.GetFolder(myFolder)

    Application.ScreenUpdating = False

    

    a = 7

    For Each oFile In oFolder.Files

        If InStr(1, oFile.Name, "xlsx") And Left(oFile.Name, 1) = "L" Then

            Set File_Open = Workbooks.Open(oFile.Path)

            For n = 1 To File_Open.Sheets.Count

                If Not File_Open.Sheets(n).Name = "IPM-BSM-SA" Then

                    'File_Open.Sheets(n).Select

                    If InStr(1, File_Open.Sheets(n).Cells(1, 1), "Logging Data Inspection") Then

                        check = True

                        col = 1

                        While check

                            If InStr(1, File_Open.Sheets(n).Cells(3, col), "D3268") Or InStr(1, File_Open.Sheets(n).Cells(2, col), "D3268") Then

                                check = False

                                Else

                                col = col + 1

                            End If

                        Wend

                        i = 1

                        check = True

                        While check

                            If File_Open.Sheets(n).Cells(i, 1) = 1 Then

                                check = False

                            Else

                                i = i + 1

                            End If

                        Wend

                        While File_Open.Sheets(n).Cells(i, 2) <> ""

                            If InStr(1, UCase(File_Open.Sheets(n).Cells(i, col)), UCase("Angle_Error")) Then

                                File_Open.Sheets(n).Rows(i).Copy Destination:=Sheet1.Rows(a)

                                Sheet1.Cells(a, 51) = File_Open.Sheets(n).Name

                                a = a + 1

                            End If

                            i = i + 1

                        Wend

                    End If

                End If

            Next n

            File_Open.Close SaveChanges:=False

        End If

    Next oFile

    Application.ScreenUpdating = True

End Sub

Thursday, March 21, 2024

VBA set text to clipboard (= ctrl+c)

 


'********* Code Start ************ ' This code was originally written by Terry Kreft. ' It is not to be altered or distributed, ' except as part of an application. ' You are free to use it in any application, ' provided the copyright notice is left unchanged. ' ' Code Courtesy of ' Terry Kreft ' Public Const GHND = &H42 Public Const CF_TEXT = 1 Private Const CF_ANSIONLY = &H400& Private Const CF_APPLY = &H200& Private Const CF_BITMAP = 2 Private Const CF_DIB = 8 Private Const CF_DIF = 5 Private Const CF_DSPBITMAP = &H82 Private Const CF_DSPENHMETAFILE = &H8E Private Const CF_DSPMETAFILEPICT = &H83 Private Const CF_DSPTEXT = &H81 Private Const CF_EFFECTS = &H100& Private Const CF_ENABLEHOOK = &H8& Private Const CF_ENABLETEMPLATE = &H10& Private Const CF_ENABLETEMPLATEHANDLE = &H20& Private Const CF_ENHMETAFILE = 14 Private Const CF_FIXEDPITCHONLY = &H4000& Private Const CF_FORCEFONTEXIST = &H10000 Private Const CF_GDIOBJFIRST = &H300 Private Const CF_GDIOBJLAST = &H3FF Private Const CF_HDROP = 15 Private Const CF_INITTOLOGFONTSTRUCT = &H40& Private Const CF_LIMITSIZE = &H2000& Private Const CF_LOCALE = 16 Private Const CF_MAX = 17 Private Const CF_METAFILEPICT = 3 Private Const CF_NOFACESEL = &H80000 Private Const CF_NOSCRIPTSEL = &H800000 Private Const CF_NOSIMULATIONS = &H1000& Private Const CF_NOSIZESEL = &H200000 Private Const CF_NOSTYLESEL = &H100000 Private Const CF_NOVECTORFONTS = &H800& Private Const CF_NOOEMFONTS = CF_NOVECTORFONTS Private Const CF_NOVERTFONTS = &H1000000 Private Const CF_OEMTEXT = 7 Private Const CF_OWNERDISPLAY = &H80 Private Const CF_PALETTE = 9 Private Const CF_PENDATA = 10 Private Const CF_PRINTERFONTS = &H2 Private Const CF_PRIVATEFIRST = &H200 Private Const CF_PRIVATELAST = &H2FF Private Const CF_RIFF = 11 Private Const CF_SCALABLEONLY = &H20000 Private Const CF_SCREENFONTS = &H1 Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS) Private Const CF_SCRIPTSONLY = CF_ANSIONLY Private Const CF_SELECTSCRIPT = &H400000 Private Const CF_SHOWHELP = &H4& Private Const CF_SYLK = 4 Private Const CF_TIFF = 6 Private Const CF_TTONLY = &H40000 Private Const CF_UNICODETEXT = 13 Private Const CF_USESTYLE = &H80& Private Const CF_WAVE = 12 Private Const CF_WYSIWYG = &H8000 Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal _ dwBytes As Long) As Long Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _ As Long Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) _ As Long Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _ ByVal lpString2 As Any) As Long Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" _ (ByVal lpString As String) As Long Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _ As Long Private Declare Function OpenClipboard Lib "user32" (ByVal Hwnd As Long) _ As Long Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As _ Long) As Long Private Declare Function EmptyClipboard Lib "user32" () As Long Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat _ As Long, ByVal hMem As Long) As Long Function ClipBoard_SetText(strCopyString As String) As Boolean Dim hGlobalMemory As Long Dim lpGlobalMemory As Long Dim hClipMemory As Long ' Allocate moveable global memory. '------------------------------------------- hGlobalMemory = GlobalAlloc(GHND, Len(strCopyString) + 1) ' Lock the block to get a far pointer ' to this memory. lpGlobalMemory = GlobalLock(hGlobalMemory) ' Copy the string to this global memory. lpGlobalMemory = lstrcpy(lpGlobalMemory, strCopyString) ' Unlock the memory and then copy to the clipboard If GlobalUnlock(hGlobalMemory) = 0 Then If OpenClipboard(0&) <> 0 Then Call EmptyClipboard hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) ClipBoard_SetText = CBool(CloseClipboard) End If End If End Function Function ClipBoard_GetText() As String Dim hClipMemory As Long Dim lpClipMemory As Long Dim strCBText As String Dim RetVal As Long Dim lngSize As Long If OpenClipboard(0&) <> 0 Then ' Obtain the handle to the global memory ' block that is referencing the text. hClipMemory = GetClipboardData(CF_TEXT) If hClipMemory <> 0 Then ' Lock Clipboard memory so we can reference ' the actual data string. lpClipMemory = GlobalLock(hClipMemory) If lpClipMemory <> 0 Then lngSize = GlobalSize(lpClipMemory) strCBText = Space$(lngSize) RetVal = lstrcpy(strCBText, lpClipMemory) RetVal = GlobalUnlock(hClipMemory) ' Peel off the null terminating character. strCBText = left(strCBText, InStr(1, strCBText, Chr$(0), 0) - 1) Else MsgBox "Could not lock memory to copy string from." End If End If Call CloseClipboard End If ClipBoard_GetText = strCBText End Function Function CopyOlePiccy(Piccy As Object) Dim hGlobalMemory As Long, lpGlobalMemory As Long Dim hClipMemory As Long, X As Long ' Allocate moveable global memory. '------------------------------------------- hGlobalMemory = GlobalAlloc(GHND, Len(Piccy) + 1) ' Lock the block to get a far pointer ' to this memory. lpGlobalMemory = GlobalLock(hGlobalMemory) 'Need to copy the object to the memory here lpGlobalMemory = lstrcpy(lpGlobalMemory, Piccy) ' Unlock the memory. If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Could not unlock memory location. Copy aborted." GoTo OutOfHere2 End If ' Open the Clipboard to copy data to. If OpenClipboard(0&) = 0 Then MsgBox "Could not open the Clipboard. Copy aborted." Exit Function End If ' Clear the Clipboard. X = EmptyClipboard() ' Copy the data to the Clipboard. hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Could not close Clipboard." End If End Function '********* Code End ************

Credit http://access.mvps.org/access/api/api0049.htm

Tuesday, October 31, 2023

VBA FTP

  Declare PtrSafe Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _

        ByVal hInternetSession As Long, ByVal sServerName As String, _

        ByVal nServerPort As Integer, ByVal sUserName As String, _

        ByVal sPassword As String, ByVal lService As Long, _

        ByVal lFlags As Long, ByVal lContext As Long) As Long

    Declare PtrSafe Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _

        ByVal sAgent As String, ByVal lAccessType As Long, _

        ByVal sProxyName As String, _

        ByVal sProxyBypass As String, ByVal lFlags As Long) As Long

    Declare PtrSafe Function FtpSetCurrentDirectory Lib "wininet.dll" Alias _

     "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, _

        ByVal lpszDirectory As String) As Boolean

    Declare PtrSafe Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" ( _

        ByVal hConnect As Long, _

        ByVal lpszLocalFile As String, _

        ByVal lpszNewRemoteFile As String, _

        ByVal dwFlags As Long, _

        ByRef dwContext As Long) As Boolean


Sub simpleFtpFileUpload()


    Dim ftp, FTP_PORT, user, password, loc_file, remote_file, ftp_folder As Variant

    'ftp_folder = "/EXPORT"

    'loc_file = ThisWorkbook.Path & "\readme.txt"

    'remote_file = ftp_folder & "/readme.txt"

    loc_file = "d:\2.jpg"

    remote_file = "2.jpg"

    FTP_PORT = "21"

    user = "ajay"

    password = "ajay"

    ftp = "192.168.0.86"


    Internet_OK = InternetOpen("", 1, "", "", 0)

    If Internet_OK Then

        FTP_OK = InternetConnect(Internet_OK, ftp, FTP_PORT, user, password, 1, 0, 0) ' INTERNET_DEFAULT_FTP_PORT or port no

        If FtpSetCurrentDirectory(FTP_OK, "/") Then

            Success = FtpPutFile(FTP_OK, loc_file, remote_file, FTP_TRANSFER_TYPE_BINARY, 0)

        End If

    End If

    If Success Then

        Debug.Print "ftp success ;)"

        MsgBox "ftp success ;)"

    Else

        Debug.Print "ftp failure :("

        MsgBox "ftp failure :("

    End If

End Sub



//////////////////////////////////////

CR: https://stackoverflow.com/questions/7737691/upload-file-via-ftp-from-excel-vba

Thursday, October 26, 2023

vba to html post

 Sub test3()

    Set ws = Worksheets("ÃÒ¡ÒÃÊÑè§«×éÍ")

    R = 5

    ws.Cells(1, 3) = ""

    vtext = ""

    i = 1


    While ws.Cells(R, 1) <> ""

        vtext = vtext & i & "" & ws.Cells(R, 3) & "  " & Int(ws.Cells(R, 13) * 100)

        R = R + 1

        i = i + 1

    Wend


    ' สร้าง HTTP Request Object

    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")


    ' สร้าง URL

    sURL = "http://192.168.0.105/xampp/line/inj.php?text=" & vtext


    ' ส่งคำขอ HTTP GET

    objHTTP.Open "GET", sURL, False

    objHTTP.setRequestHeader "Content-Type", "text/xml"

    objHTTP.send ""


    ' รอให้การเรียก URL เสร็จสิ้นก่อนที่จะดำเนินการถัดไป

    Do While objHTTP.readyState <> 4

        DoEvents

    Loop


    ' ตรวจสอบการเรียก URL ว่าเสร็จสิ้นหรือไม่ (สถานะ 200 หมายถึง OK)

    If objHTTP.Status = 200 Then

        ' การเรียก URL เสร็จสิ้น และส่งข้อมูลเพียงครั้งเดียว

        MsgBox "ส่งข้อมูลสำเร็จ"

    Else

        ' การเรียก URL มีปัญหา

        MsgBox "มีปัญหาในการส่งข้อมูล"

    End If


    ' ลบอ็อบเจ็กต์ HTTP Request

    Set objHTTP = Nothing

End Sub


VBA image to base64

 Public Function EncodeFile(strPicPath As String) As String

    Const adTypeBinary = 1          ' Binary file is encoded

    ' Variables for encoding
    Dim objXML
    Dim objDocElem

    ' Variable for reading binary picture
    Dim objStream

    ' Open data stream from picture
    Set objStream = CreateObject("ADODB.Stream")
    objStream.Type = adTypeBinary
    objStream.Open
    objStream.LoadFromFile (strPicPath)

    ' Create XML Document object and root node
    ' that will contain the data
    Set objXML = CreateObject("MSXml2.DOMDocument")
    Set objDocElem = objXML.createElement("Base64Data")
    objDocElem.dataType = "bin.base64"

    ' Set binary value
    objDocElem.nodeTypedValue = objStream.Read()

    ' Get base64 value
    EncodeFile = objDocElem.Text

    ' Clean all
    Set objXML = Nothing
    Set objDocElem = Nothing
    Set objStream = Nothing

End Function

REF-->https://stackoverflow.com/questions/2043393/convert-image-jpg-to-base64-in-excel-vba